mirror of
https://github.com/haskell/ghcide.git
synced 2024-12-13 18:23:38 +03:00
Introduce a newtype for file paths with normalized slashes (#1633)
This implements part 2 of #1507 and fixes the daml-ghc-test-dev test suite on Windows (not enabled on CI due to GRPC issues). I have also tested this in the IDE on Windows and Linux.
This commit is contained in:
Moritz Kiefer
GitHub
parent
3fd52a88ab
commit
41d693ad03
@ -92,7 +92,7 @@ getSrcSpanInfos
|
||||
:: IdeOptions
|
||||
-> ParsedModule
|
||||
-> HscEnv
|
||||
-> [(Located ModuleName, Maybe FilePath)]
|
||||
-> [(Located ModuleName, Maybe NormalizedFilePath)]
|
||||
-> TcModuleResult
|
||||
-> IO [SpanInfo]
|
||||
getSrcSpanInfos opt mod env imports tc =
|
||||
|
||||
@ -36,20 +36,20 @@ import Module
|
||||
|
||||
-- | Unprocessed results that we get from following all imports recursively starting from a module.
|
||||
data RawDependencyInformation = RawDependencyInformation
|
||||
{ moduleDependencies :: Map FilePath (Either ModuleParseError [(Located ModuleName, Maybe FilePath)])
|
||||
, pkgDependencies :: Map FilePath (Set InstalledUnitId)
|
||||
{ moduleDependencies :: Map NormalizedFilePath (Either ModuleParseError [(Located ModuleName, Maybe NormalizedFilePath)])
|
||||
, pkgDependencies :: Map NormalizedFilePath (Set InstalledUnitId)
|
||||
-- ^ Transitive dependencies on pkgs of this file, i.e. immidiate package dependencies and the
|
||||
-- transitive package dependencies of those packages.
|
||||
}
|
||||
|
||||
data DependencyInformation =
|
||||
DependencyInformation
|
||||
{ depErrorNodes :: Map FilePath (NonEmpty NodeError)
|
||||
{ depErrorNodes :: Map NormalizedFilePath (NonEmpty NodeError)
|
||||
-- ^ Nodes that cannot be processed correctly.
|
||||
, depModuleDeps :: Map FilePath (Set FilePath)
|
||||
, depModuleDeps :: Map NormalizedFilePath (Set NormalizedFilePath)
|
||||
-- ^ For a non-error node, this contains the set of module immediate dependencies
|
||||
-- in the same package.
|
||||
, depPkgDeps :: Map FilePath (Set InstalledUnitId)
|
||||
, depPkgDeps :: Map NormalizedFilePath (Set InstalledUnitId)
|
||||
-- ^ For a non-error node, this contains the set of immediate pkg deps.
|
||||
} deriving (Show, Generic)
|
||||
|
||||
@ -69,7 +69,7 @@ instance NFData LocateError
|
||||
|
||||
-- | An error attached to a node in the dependency graph.
|
||||
data NodeError
|
||||
= PartOfCycle (Located ModuleName) [FilePath]
|
||||
= PartOfCycle (Located ModuleName) [NormalizedFilePath]
|
||||
-- ^ This module is part of an import cycle. The module name corresponds
|
||||
-- to the import that enters the cycle starting from this module.
|
||||
-- The list of filepaths represents the elements
|
||||
@ -94,10 +94,12 @@ instance NFData NodeError where
|
||||
-- `ErrorNode`. Otherwise it is a `SuccessNode`.
|
||||
data NodeResult
|
||||
= ErrorNode (NonEmpty NodeError)
|
||||
| SuccessNode [(Located ModuleName, FilePath)]
|
||||
| SuccessNode [(Located ModuleName, NormalizedFilePath)]
|
||||
deriving Show
|
||||
|
||||
partitionNodeResults :: [(a, NodeResult)] -> ([(a, NonEmpty NodeError)], [(a, [(Located ModuleName, FilePath)])])
|
||||
partitionNodeResults
|
||||
:: [(a, NodeResult)]
|
||||
-> ([(a, NonEmpty NodeError)], [(a, [(Located ModuleName, NormalizedFilePath)])])
|
||||
partitionNodeResults = partitionEithers . map f
|
||||
where f (a, ErrorNode errs) = Left (a, errs)
|
||||
f (a, SuccessNode imps) = Right (a, imps)
|
||||
@ -116,7 +118,7 @@ processDependencyInformation rawResults =
|
||||
, depPkgDeps = pkgDependencies rawResults
|
||||
}
|
||||
where resultGraph = buildResultGraph rawResults
|
||||
successEdges :: [(FilePath, FilePath, [FilePath])]
|
||||
successEdges :: [(NormalizedFilePath, NormalizedFilePath, [NormalizedFilePath])]
|
||||
successEdges = map (\(k,ks) -> (k,k,ks)) $ MS.toList $
|
||||
MS.map (map snd) $ MS.mapMaybe successNode resultGraph
|
||||
moduleDeps =
|
||||
@ -131,22 +133,22 @@ processDependencyInformation rawResults =
|
||||
-- 2. Mark each node that has a parse error as an error node.
|
||||
-- 3. Mark each node whose immediate children could not be located as an error.
|
||||
-- 4. Recursively propagate errors to parents if they are not already error nodes.
|
||||
buildResultGraph :: RawDependencyInformation -> Map FilePath NodeResult
|
||||
buildResultGraph :: RawDependencyInformation -> Map NormalizedFilePath NodeResult
|
||||
buildResultGraph g = propagatedErrors
|
||||
where
|
||||
sccs = stronglyConnComp (graphEdges g)
|
||||
(_, cycles) = partitionSCC sccs
|
||||
cycleErrors :: Map FilePath NodeResult
|
||||
cycleErrors :: Map NormalizedFilePath NodeResult
|
||||
cycleErrors = MS.unionsWith (<>) $ map errorsForCycle cycles
|
||||
errorsForCycle :: [FilePath] -> Map FilePath NodeResult
|
||||
errorsForCycle :: [NormalizedFilePath] -> Map NormalizedFilePath NodeResult
|
||||
errorsForCycle files =
|
||||
MS.fromListWith (<>) (concatMap (cycleErrorsForFile files) files)
|
||||
cycleErrorsForFile :: [FilePath] -> FilePath -> [(FilePath,NodeResult)]
|
||||
cycleErrorsForFile :: [NormalizedFilePath] -> NormalizedFilePath -> [(NormalizedFilePath,NodeResult)]
|
||||
cycleErrorsForFile cycle f =
|
||||
let entryPoints = mapMaybe (findImport f) cycle
|
||||
in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints
|
||||
otherErrors = MS.map otherErrorsForFile (moduleDependencies g)
|
||||
otherErrorsForFile :: Either ModuleParseError [(Located ModuleName, Maybe FilePath)] -> NodeResult
|
||||
otherErrorsForFile :: Either ModuleParseError [(Located ModuleName, Maybe NormalizedFilePath)] -> NodeResult
|
||||
otherErrorsForFile (Left err) = ErrorNode (ParseError err :| [])
|
||||
otherErrorsForFile (Right imports) =
|
||||
let toEither (imp, Nothing) = Left imp
|
||||
@ -171,17 +173,17 @@ buildResultGraph g = propagatedErrors
|
||||
in case nonEmpty errs of
|
||||
Nothing -> n
|
||||
Just errs' -> ErrorNode (NonEmpty.map (ParentOfErrorNode . fst) errs')
|
||||
findImport :: FilePath -> FilePath -> Maybe (Located ModuleName)
|
||||
findImport :: NormalizedFilePath -> NormalizedFilePath -> Maybe (Located ModuleName)
|
||||
findImport file importedFile =
|
||||
case moduleDependencies g MS.! file of
|
||||
Left _ -> error "Tried to call findImport on a module with a parse error"
|
||||
Right imports ->
|
||||
fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) imports
|
||||
|
||||
graphEdges :: RawDependencyInformation -> [(FilePath, FilePath, [FilePath])]
|
||||
graphEdges :: RawDependencyInformation -> [(NormalizedFilePath, NormalizedFilePath, [NormalizedFilePath])]
|
||||
graphEdges g =
|
||||
map (\(k, ks) -> (k, k, ks)) $ MS.toList $ MS.map deps $ moduleDependencies g
|
||||
where deps :: Either e [(i, Maybe FilePath)] -> [FilePath]
|
||||
where deps :: Either e [(i, Maybe NormalizedFilePath)] -> [NormalizedFilePath]
|
||||
deps (Left _) = []
|
||||
deps (Right imports) = mapMaybe snd imports
|
||||
|
||||
@ -190,17 +192,17 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest
|
||||
partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
|
||||
partitionSCC [] = ([], [])
|
||||
|
||||
transitiveDeps :: DependencyInformation -> FilePath -> Maybe TransitiveDependencies
|
||||
transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
|
||||
transitiveDeps DependencyInformation{..} f = do
|
||||
reachableVs <- Set.delete f . Set.fromList . map (fst3 . fromVertex) . reachable g <$> toVertex f
|
||||
let transitiveModuleDeps = filter (\v -> v `Set.member` reachableVs) $ map (fst3 . fromVertex) vs
|
||||
let transitivePkgDeps = Set.toList $ foldMap (\f -> MS.findWithDefault Set.empty f depPkgDeps) (f : transitiveModuleDeps)
|
||||
pure $ TransitiveDependencies {..}
|
||||
pure TransitiveDependencies {..}
|
||||
where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, Set.toList fs)) $ MS.toList depModuleDeps)
|
||||
vs = topSort g
|
||||
|
||||
data TransitiveDependencies = TransitiveDependencies
|
||||
{ transitiveModuleDeps :: [FilePath]
|
||||
{ transitiveModuleDeps :: [NormalizedFilePath]
|
||||
-- ^ Transitive module dependencies in topological order.
|
||||
-- The module itself is not included.
|
||||
, transitivePkgDeps :: [InstalledUnitId]
|
||||
|
||||
@ -11,6 +11,7 @@ module Development.IDE.Functions.FindImports
|
||||
|
||||
import Development.IDE.Functions.GHCError as ErrUtils
|
||||
import Development.IDE.Orphans()
|
||||
import Development.IDE.Types.Diagnostics
|
||||
-- GHC imports
|
||||
import BasicTypes (StringLiteral(..))
|
||||
import DynFlags
|
||||
@ -30,7 +31,7 @@ import qualified Control.Monad.Trans.Except as Ex
|
||||
import System.FilePath
|
||||
|
||||
data Import
|
||||
= FileImport FilePath
|
||||
= FileImport NormalizedFilePath
|
||||
| PackageImport M.InstalledUnitId
|
||||
deriving (Show)
|
||||
|
||||
@ -67,11 +68,11 @@ getImportsParsed dflags (L loc parsed) = do
|
||||
locateModuleFile :: MonadIO m
|
||||
=> DynFlags
|
||||
-> [String]
|
||||
-> (FilePath -> m Bool)
|
||||
-> (NormalizedFilePath -> m Bool)
|
||||
-> ModuleName
|
||||
-> m (Maybe FilePath)
|
||||
-> m (Maybe NormalizedFilePath)
|
||||
locateModuleFile dflags exts doesExist modName = do
|
||||
let candidates = [ prefix </> M.moduleNameSlashes modName <.> ext | prefix <- importPaths dflags, ext <- exts]
|
||||
let candidates = [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> ext) | prefix <- importPaths dflags, ext <- exts]
|
||||
findM doesExist candidates
|
||||
|
||||
-- | locate a module in either the file system or the package database. Where we go from *daml to
|
||||
@ -80,7 +81,7 @@ locateModule
|
||||
:: MonadIO m
|
||||
=> DynFlags
|
||||
-> [String]
|
||||
-> (FilePath -> m Bool)
|
||||
-> (NormalizedFilePath -> m Bool)
|
||||
-> Located ModuleName
|
||||
-> Maybe FastString
|
||||
-> m (Either [FileDiagnostic] Import)
|
||||
|
||||
@ -50,7 +50,7 @@ mkDiag dflags src e =
|
||||
case toDSeverity $ errMsgSeverity e of
|
||||
Nothing -> Nothing
|
||||
Just bSeverity ->
|
||||
Just $ (srcSpanToFilename $ errMsgSpan e,)
|
||||
Just $ (toNormalizedFilePath $ srcSpanToFilename (errMsgSpan e),)
|
||||
Diagnostic
|
||||
{ _range = srcSpanToRange $ errMsgSpan e
|
||||
, _severity = Just bSeverity
|
||||
@ -78,7 +78,7 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real
|
||||
|
||||
srcSpanToLocation :: SrcSpan -> Location
|
||||
srcSpanToLocation src =
|
||||
Location (fromNormalizedUri $ D.filePathToUri' $ srcSpanToFilename src) (srcSpanToRange src)
|
||||
Location (filePathToUri $ srcSpanToFilename src) (srcSpanToRange src)
|
||||
|
||||
-- | Convert a GHC severity to a DAML compiler Severity. Severities below
|
||||
-- "Warning" level are dropped (returning Nothing).
|
||||
|
||||
@ -21,6 +21,7 @@ import Desugar
|
||||
import GHC
|
||||
import GhcMonad
|
||||
import FastString (mkFastString)
|
||||
import Development.IDE.Types.Diagnostics
|
||||
import Development.IDE.Types.SpanInfo
|
||||
import Development.IDE.Functions.GHCError (zeroSpan)
|
||||
import Prelude hiding (mod)
|
||||
@ -29,7 +30,7 @@ import Var
|
||||
|
||||
-- | Get ALL source spans in the module.
|
||||
getSpanInfo :: GhcMonad m
|
||||
=> [(Located ModuleName, Maybe FilePath)] -- ^ imports
|
||||
=> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
|
||||
-> TypecheckedModule
|
||||
-> m [SpanInfo]
|
||||
getSpanInfo mods tcm =
|
||||
@ -94,17 +95,17 @@ getTypeLPat _ pat =
|
||||
(Named (dataConName dc), spn)
|
||||
getSpanSource _ = (NoSource, noSrcSpan)
|
||||
|
||||
importInfo :: [(Located ModuleName, Maybe FilePath)]
|
||||
importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]
|
||||
-> [(SpanSource, SrcSpan, Maybe Type)]
|
||||
importInfo = mapMaybe (uncurry wrk) where
|
||||
wrk :: Located ModuleName -> Maybe FilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)
|
||||
wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)
|
||||
wrk modName = \case
|
||||
Nothing -> Nothing
|
||||
Just afp -> Just (afpToSpanSource afp, getLoc modName, Nothing)
|
||||
Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName, Nothing)
|
||||
|
||||
-- TODO make this point to the module name
|
||||
afpToSpanSource :: FilePath -> SpanSource
|
||||
afpToSpanSource afp = Span $ RealSrcSpan $ zeroSpan $ mkFastString afp
|
||||
fpToSpanSource :: FilePath -> SpanSource
|
||||
fpToSpanSource fp = Span $ RealSrcSpan $ zeroSpan $ mkFastString fp
|
||||
|
||||
-- | Get ALL source spans in the source.
|
||||
listifyAllSpans :: Typeable a
|
||||
|
||||
@ -97,7 +97,7 @@ getFileExistsRule vfs =
|
||||
alwaysRerun
|
||||
res <- liftIO $ handle (\(_ :: IOException) -> return False) $
|
||||
(isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
|
||||
Dir.doesFileExist file
|
||||
Dir.doesFileExist (fromNormalizedFilePath file)
|
||||
return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
|
||||
|
||||
|
||||
@ -107,14 +107,16 @@ showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicos
|
||||
getModificationTimeRule :: VFSHandle -> Rules ()
|
||||
getModificationTimeRule vfs =
|
||||
defineEarlyCutoff $ \GetModificationTime file -> do
|
||||
let file' = fromNormalizedFilePath file
|
||||
let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just $ ModificationTime time))
|
||||
alwaysRerun
|
||||
mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
|
||||
case mbVirtual of
|
||||
Just (VirtualFile ver _ _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
|
||||
Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file) `catch` \(e :: IOException) -> do
|
||||
let err | isDoesNotExistError e = "File does not exist: " ++ file
|
||||
| otherwise = "IO error while reading " ++ file ++ ", " ++ displayException e
|
||||
Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file')
|
||||
`catch` \(e :: IOException) -> do
|
||||
let err | isDoesNotExistError e = "File does not exist: " ++ file'
|
||||
| otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
|
||||
return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
|
||||
|
||||
|
||||
@ -127,16 +129,16 @@ getFileContentsRule vfs =
|
||||
mbVirtual <- getVirtualFile vfs $ filePathToUri' file
|
||||
case mbVirtual of
|
||||
Just (VirtualFile _ rope _) -> return $ textToStringBuffer $ Rope.toText rope
|
||||
Nothing -> hGetStringBuffer file
|
||||
Nothing -> hGetStringBuffer (fromNormalizedFilePath file)
|
||||
case res of
|
||||
Left err -> return ([err], Nothing)
|
||||
Right contents -> return ([], Just (time, contents))
|
||||
|
||||
|
||||
getFileContents :: FilePath -> Action (FileVersion, StringBuffer)
|
||||
getFileContents :: NormalizedFilePath -> Action (FileVersion, StringBuffer)
|
||||
getFileContents = use_ GetFileContents
|
||||
|
||||
getFileExists :: FilePath -> Action Bool
|
||||
getFileExists :: NormalizedFilePath -> Action Bool
|
||||
getFileExists =
|
||||
-- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
|
||||
-- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
|
||||
@ -153,7 +155,7 @@ fileStoreRules vfs = do
|
||||
|
||||
|
||||
-- | Notify the compiler service of a modified buffer
|
||||
setBufferModified :: IdeState -> FilePath -> Maybe T.Text -> IO ()
|
||||
setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()
|
||||
setBufferModified state absFile mbContents = do
|
||||
VFSHandle{..} <- getIdeGlobalState state
|
||||
case mbContents of
|
||||
|
||||
@ -74,41 +74,38 @@ defineNoFile f = define $ \k file -> do
|
||||
|
||||
|
||||
-- | Get GHC Core for the supplied file.
|
||||
getGhcCore :: FilePath -> Action (Maybe [CoreModule])
|
||||
getGhcCore :: NormalizedFilePath -> Action (Maybe [CoreModule])
|
||||
getGhcCore file = eitherToMaybe <$> runExceptT (coresForFile file)
|
||||
|
||||
-- | Generate the GHC Core for the supplied file and its dependencies.
|
||||
coresForFile :: FilePath -> ExceptT [FileDiagnostic] Action [CoreModule]
|
||||
coresForFile :: NormalizedFilePath -> ExceptT [FileDiagnostic] Action [CoreModule]
|
||||
coresForFile file = do
|
||||
files <- transitiveModuleDeps <$> useE GetDependencies file
|
||||
pms <- usesE GetParsedModule $ files ++ [file]
|
||||
fs <- liftIO
|
||||
. mapM fileFromParsedModule
|
||||
$ pms
|
||||
cores <- usesE GenerateCore fs
|
||||
cores <- usesE GenerateCore $ map fileFromParsedModule pms
|
||||
pure (map Compile.gmCore cores)
|
||||
|
||||
|
||||
|
||||
-- | Get all transitive file dependencies of a given module.
|
||||
-- Does not include the file itself.
|
||||
getDependencies :: FilePath -> Action (Maybe [FilePath])
|
||||
getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
|
||||
getDependencies file =
|
||||
eitherToMaybe <$>
|
||||
(runExceptT $ transitiveModuleDeps <$> useE GetDependencies file)
|
||||
|
||||
getDalfDependencies :: FilePath -> Action (Maybe [InstalledUnitId])
|
||||
getDalfDependencies :: NormalizedFilePath -> Action (Maybe [InstalledUnitId])
|
||||
getDalfDependencies file =
|
||||
eitherToMaybe <$>
|
||||
(runExceptT $ transitivePkgDeps <$> useE GetDependencies file)
|
||||
|
||||
-- | Documentation at point.
|
||||
getAtPoint :: FilePath -> Position -> Action (Maybe (Maybe Range, [HoverText]))
|
||||
getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [HoverText]))
|
||||
getAtPoint file pos = do
|
||||
fmap (either (const Nothing) id) . runExceptT $ getAtPointForFile file pos
|
||||
|
||||
-- | Goto Definition.
|
||||
getDefinition :: FilePath -> Position -> Action (Maybe Location)
|
||||
getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
|
||||
getDefinition file pos = do
|
||||
fmap (either (const Nothing) id) . runExceptT $ getDefinitionForFile file pos
|
||||
|
||||
@ -118,18 +115,18 @@ getDefinition file pos = do
|
||||
|
||||
useE
|
||||
:: IdeRule k v
|
||||
=> k -> FilePath -> ExceptT [FileDiagnostic] Action v
|
||||
=> k -> NormalizedFilePath -> ExceptT [FileDiagnostic] Action v
|
||||
useE k = ExceptT . fmap toIdeResultSilent . use k
|
||||
|
||||
-- picks the first error
|
||||
usesE
|
||||
:: IdeRule k v
|
||||
=> k -> [FilePath] -> ExceptT [FileDiagnostic] Action [v]
|
||||
=> k -> [NormalizedFilePath] -> ExceptT [FileDiagnostic] Action [v]
|
||||
usesE k = ExceptT . fmap (mapM toIdeResultSilent) . uses k
|
||||
|
||||
-- | Try to get hover text for the name under point.
|
||||
getAtPointForFile
|
||||
:: FilePath
|
||||
:: NormalizedFilePath
|
||||
-> Position
|
||||
-> ExceptT [FileDiagnostic] Action (Maybe (Maybe Range, [HoverText]))
|
||||
getAtPointForFile file pos = do
|
||||
@ -138,7 +135,7 @@ getAtPointForFile file pos = do
|
||||
spans <- useE GetSpanInfo file
|
||||
return $ AtPoint.atPoint (map Compile.tmrModule tms) spans pos
|
||||
|
||||
getDefinitionForFile :: FilePath -> Position -> ExceptT [FileDiagnostic] Action (Maybe Location)
|
||||
getDefinitionForFile :: NormalizedFilePath -> Position -> ExceptT [FileDiagnostic] Action (Maybe Location)
|
||||
getDefinitionForFile file pos = do
|
||||
spans <- useE GetSpanInfo file
|
||||
pkgState <- useE GhcSession ""
|
||||
@ -167,7 +164,7 @@ getParsedModuleRule =
|
||||
(_, contents) <- getFileContents file
|
||||
packageState <- use_ GhcSession ""
|
||||
opt <- getOpts
|
||||
liftIO $ Compile.parseModule opt packageState file contents
|
||||
liftIO $ Compile.parseModule opt packageState (fromNormalizedFilePath file) contents
|
||||
|
||||
getLocatedImportsRule :: Rules ()
|
||||
getLocatedImportsRule =
|
||||
@ -185,7 +182,7 @@ getLocatedImportsRule =
|
||||
|
||||
-- | Given a target file path, construct the raw dependency results by following
|
||||
-- imports recursively.
|
||||
rawDependencyInformation :: FilePath -> ExceptT [FileDiagnostic] Action RawDependencyInformation
|
||||
rawDependencyInformation :: NormalizedFilePath -> ExceptT [FileDiagnostic] Action RawDependencyInformation
|
||||
rawDependencyInformation f = go (Set.singleton f) Map.empty Map.empty
|
||||
where go fs !modGraph !pkgs =
|
||||
case Set.minView fs of
|
||||
@ -242,7 +239,7 @@ reportImportCyclesRule =
|
||||
, _relatedInformation = Nothing
|
||||
}
|
||||
where loc = srcSpanToLocation (getLoc imp)
|
||||
fp = srcSpanToFilename (getLoc imp)
|
||||
fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
|
||||
getModuleName file = do
|
||||
pm <- useE GetParsedModule file
|
||||
pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
|
||||
@ -324,12 +321,12 @@ mainRule = do
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
fileFromParsedModule :: ParsedModule -> IO FilePath
|
||||
fileFromParsedModule = pure . ms_hspp_file . pm_mod_summary
|
||||
fileFromParsedModule :: ParsedModule -> NormalizedFilePath
|
||||
fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary
|
||||
|
||||
fileImports ::
|
||||
[(Located ModuleName, Maybe Import)]
|
||||
-> [(Located ModuleName, Maybe FilePath)]
|
||||
-> [(Located ModuleName, Maybe NormalizedFilePath)]
|
||||
fileImports = mapMaybe $ \case
|
||||
(modName, Nothing) -> Just (modName, Nothing)
|
||||
(modName, Just (FileImport absFile)) -> Just (modName, Just absFile)
|
||||
|
||||
@ -27,6 +27,7 @@ import qualified Development.IDE.Logger as Logger
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Development.IDE.Functions.GHCError
|
||||
import Development.IDE.Types.Diagnostics (NormalizedFilePath)
|
||||
import Development.Shake hiding (Diagnostic, Env, newCache)
|
||||
import qualified Language.Haskell.LSP.Messages as LSP
|
||||
|
||||
@ -39,7 +40,7 @@ import Development.IDE.State.Shake
|
||||
data Env = Env
|
||||
{ envOptions :: IdeOptions
|
||||
-- ^ Compiler options.
|
||||
, envOfInterestVar :: Var (Set FilePath)
|
||||
, envOfInterestVar :: Var (Set NormalizedFilePath)
|
||||
-- ^ The files of interest.
|
||||
, envUniqSupplyVar :: Var UniqSupply
|
||||
-- ^ The unique supply of names used by the compiler.
|
||||
@ -107,7 +108,7 @@ runActions x = join . shakeRun x
|
||||
|
||||
|
||||
-- | Set the files-of-interest which will be built and kept-up-to-date.
|
||||
setFilesOfInterest :: IdeState -> Set FilePath -> IO ()
|
||||
setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()
|
||||
setFilesOfInterest state files = do
|
||||
Env{..} <- getIdeGlobalState state
|
||||
-- update vars synchronously
|
||||
|
||||
@ -119,7 +119,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 (FilePath, Key) (Maybe Dynamic)
|
||||
type Values = Map.HashMap (NormalizedFilePath, Key) (Maybe Dynamic)
|
||||
|
||||
-- | Key type
|
||||
data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
|
||||
@ -195,7 +195,7 @@ profileCounter = unsafePerformIO $ newVar 0
|
||||
setValues :: IdeRule k v
|
||||
=> Var Values
|
||||
-> k
|
||||
-> FilePath
|
||||
-> NormalizedFilePath
|
||||
-> Maybe v
|
||||
-> IO ()
|
||||
setValues state key file val = modifyVar_ state $
|
||||
@ -204,7 +204,7 @@ setValues state key file val = modifyVar_ state $
|
||||
-- | 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
|
||||
-- a value
|
||||
getValues :: forall k v. IdeRule k v => Var Values -> k -> FilePath -> IO (Maybe (Maybe v))
|
||||
getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Maybe v))
|
||||
getValues state key file = do
|
||||
vs <- readVar state
|
||||
return $ do
|
||||
@ -255,7 +255,7 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts = modifyVar shakeAbort $
|
||||
-- | Use the last stale value, if it's ever been computed.
|
||||
useStale
|
||||
:: IdeRule k v
|
||||
=> IdeState -> k -> FilePath -> IO (Maybe v)
|
||||
=> IdeState -> k -> NormalizedFilePath -> IO (Maybe v)
|
||||
useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =
|
||||
join <$> getValues state k fp
|
||||
|
||||
@ -271,7 +271,7 @@ unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
|
||||
writeVar diagnostics emptyDiagnostics
|
||||
|
||||
-- | Clear the results for all files that do not match the given predicate.
|
||||
garbageCollect :: (FilePath -> Bool) -> Action ()
|
||||
garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
|
||||
garbageCollect keep = do
|
||||
ShakeExtras{state, diagnostics} <- getShakeExtras
|
||||
liftIO $
|
||||
@ -280,17 +280,17 @@ garbageCollect keep = do
|
||||
|
||||
define
|
||||
:: IdeRule k v
|
||||
=> (k -> FilePath -> Action (IdeResult v)) -> Rules ()
|
||||
=> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
|
||||
define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v
|
||||
|
||||
use :: IdeRule k v
|
||||
=> k -> FilePath -> Action (Maybe v)
|
||||
=> k -> NormalizedFilePath -> Action (Maybe v)
|
||||
use key file = head <$> uses key [file]
|
||||
|
||||
use_ :: IdeRule k v => k -> FilePath -> Action v
|
||||
use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
|
||||
use_ key file = head <$> uses_ key [file]
|
||||
|
||||
uses_ :: IdeRule k v => k -> [FilePath] -> Action [v]
|
||||
uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
|
||||
uses_ key files = do
|
||||
res <- uses key files
|
||||
case sequence res of
|
||||
@ -321,7 +321,7 @@ isBadDependency x
|
||||
| otherwise = False
|
||||
|
||||
|
||||
newtype Q k = Q (k, FilePath)
|
||||
newtype Q k = Q (k, NormalizedFilePath)
|
||||
deriving (Eq,Hashable,NFData)
|
||||
|
||||
-- Using Database we don't need Binary instances for keys
|
||||
@ -330,7 +330,7 @@ instance Binary (Q k) where
|
||||
get = fail "Binary.get not defined for type Development.IDE.State.Shake.Q"
|
||||
|
||||
instance Show k => Show (Q k) where
|
||||
show (Q (k, file)) = show k ++ "; " ++ file
|
||||
show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file
|
||||
|
||||
-- | Invariant: the 'v' must be in normal form (fully evaluated).
|
||||
-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
|
||||
@ -346,12 +346,12 @@ type instance RuleResult (Q k) = A (RuleResult k)
|
||||
|
||||
-- | Compute the value
|
||||
uses :: IdeRule k v
|
||||
=> k -> [FilePath] -> Action [Maybe v]
|
||||
=> k -> [NormalizedFilePath] -> Action [Maybe v]
|
||||
uses key files = map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
|
||||
|
||||
defineEarlyCutoff
|
||||
:: IdeRule k v
|
||||
=> (k -> FilePath -> Action (Maybe BS.ByteString, IdeResult v))
|
||||
=> (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
|
||||
-> Rules ()
|
||||
defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do
|
||||
extras@ShakeExtras{state} <- getShakeExtras
|
||||
@ -383,7 +383,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old m
|
||||
unwrap x = if BS.null x then Nothing else Just $ BS.tail x
|
||||
|
||||
updateFileDiagnostics ::
|
||||
FilePath
|
||||
NormalizedFilePath
|
||||
-> Key
|
||||
-> ShakeExtras
|
||||
-> [Diagnostic] -- ^ current results
|
||||
@ -397,13 +397,13 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, state} current = do
|
||||
let newDiags = getFileDiagnostics fp newDiagsStore
|
||||
pure (newDiagsStore, (newDiags, oldDiags))
|
||||
when (newDiags /= oldDiags) $
|
||||
sendEvent $ publishDiagnosticsNotification fp newDiags
|
||||
sendEvent $ publishDiagnosticsNotification (fromNormalizedFilePath fp) newDiags
|
||||
|
||||
publishDiagnosticsNotification :: FilePath -> [Diagnostic] -> LSP.FromServerMessage
|
||||
publishDiagnosticsNotification fp diags =
|
||||
LSP.NotPublishDiagnostics $
|
||||
LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $
|
||||
LSP.PublishDiagnosticsParams (fromNormalizedUri $ filePathToUri' fp) (List diags)
|
||||
LSP.PublishDiagnosticsParams (LSP.filePathToUri fp) (List diags)
|
||||
|
||||
setPriority :: (Enum a) => a -> Action ()
|
||||
setPriority p =
|
||||
|
||||
@ -21,6 +21,9 @@ module Development.IDE.Types.Diagnostics (
|
||||
NormalizedUri,
|
||||
LSP.toNormalizedUri,
|
||||
LSP.fromNormalizedUri,
|
||||
NormalizedFilePath,
|
||||
toNormalizedFilePath,
|
||||
fromNormalizedFilePath,
|
||||
noLocation,
|
||||
noRange,
|
||||
noFilePath,
|
||||
@ -31,6 +34,7 @@ module Development.IDE.Types.Diagnostics (
|
||||
showDiagnostics,
|
||||
showDiagnosticsColored,
|
||||
defDiagnostic,
|
||||
filePathToUri,
|
||||
filePathToUri',
|
||||
uriToFilePath',
|
||||
ProjectDiagnostics,
|
||||
@ -42,14 +46,18 @@ module Development.IDE.Types.Diagnostics (
|
||||
prettyDiagnostics
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Exception
|
||||
import Data.Either.Combinators
|
||||
import Data.Maybe as Maybe
|
||||
import Data.Foldable
|
||||
import Data.Hashable
|
||||
import qualified Data.Map as Map
|
||||
import Data.String
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Prettyprint.Doc.Syntax
|
||||
import qualified Data.SortedList as SL
|
||||
import System.FilePath
|
||||
import qualified Text.PrettyPrint.Annotated.HughesPJClass as Pretty
|
||||
import qualified Language.Haskell.LSP.Types as LSP
|
||||
import Language.Haskell.LSP.Types as LSP (
|
||||
@ -67,6 +75,26 @@ import Language.Haskell.LSP.Diagnostics
|
||||
|
||||
import Development.IDE.Types.Location
|
||||
|
||||
-- | Newtype wrapper around FilePath that always has normalized slashes.
|
||||
newtype NormalizedFilePath = NormalizedFilePath FilePath
|
||||
deriving (Eq, Ord, Show, Hashable, NFData)
|
||||
|
||||
instance IsString NormalizedFilePath where
|
||||
fromString = toNormalizedFilePath
|
||||
|
||||
toNormalizedFilePath :: FilePath -> NormalizedFilePath
|
||||
toNormalizedFilePath "" = NormalizedFilePath ""
|
||||
toNormalizedFilePath fp = NormalizedFilePath $ normalise' fp
|
||||
where
|
||||
-- We do not use System.FilePath’s normalise here since that
|
||||
-- also normalises things like the case of the drive letter
|
||||
-- which NormalizedUri does not normalise so we get VFS lookup failures.
|
||||
normalise' :: FilePath -> FilePath
|
||||
normalise' = map (\c -> if isPathSeparator c then pathSeparator else c)
|
||||
|
||||
fromNormalizedFilePath :: NormalizedFilePath -> FilePath
|
||||
fromNormalizedFilePath (NormalizedFilePath fp) = fp
|
||||
|
||||
-- | We use an empty string as a filepath when we don’t have a file.
|
||||
-- However, haskell-lsp doesn’t support that in uriToFilePath and given
|
||||
-- that it is not a valid filepath it does not make sense to upstream a fix.
|
||||
@ -76,16 +104,16 @@ uriToFilePath' uri
|
||||
| uri == filePathToUri "" = Just ""
|
||||
| otherwise = LSP.uriToFilePath uri
|
||||
|
||||
filePathToUri' :: FilePath -> NormalizedUri
|
||||
filePathToUri' fp = toNormalizedUri $ filePathToUri fp
|
||||
filePathToUri' :: NormalizedFilePath -> NormalizedUri
|
||||
filePathToUri' = toNormalizedUri . filePathToUri . fromNormalizedFilePath
|
||||
|
||||
ideErrorText :: FilePath -> T.Text -> FileDiagnostic
|
||||
ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
|
||||
ideErrorText fp = errorDiag fp "Ide Error"
|
||||
|
||||
ideErrorPretty :: Pretty.Pretty e => FilePath -> e -> FileDiagnostic
|
||||
ideErrorPretty :: Pretty.Pretty e => NormalizedFilePath -> e -> FileDiagnostic
|
||||
ideErrorPretty fp = ideErrorText fp . T.pack . Pretty.prettyShow
|
||||
|
||||
errorDiag :: FilePath -> T.Text -> T.Text -> FileDiagnostic
|
||||
errorDiag :: NormalizedFilePath -> T.Text -> T.Text -> FileDiagnostic
|
||||
errorDiag fp src msg =
|
||||
(fp, diagnostic noRange LSP.DsError src msg)
|
||||
|
||||
@ -119,9 +147,11 @@ defDiagnostic _range _message = LSP.Diagnostic {
|
||||
, _relatedInformation = Nothing
|
||||
}
|
||||
|
||||
ideTryIOException :: FilePath -> IO a -> IO (Either FileDiagnostic a)
|
||||
ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
|
||||
ideTryIOException fp act =
|
||||
mapLeft (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e) <$> try act
|
||||
mapLeft
|
||||
(\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)
|
||||
<$> try act
|
||||
|
||||
-- | Human readable diagnostics for a specific file.
|
||||
--
|
||||
@ -129,8 +159,8 @@ ideTryIOException fp act =
|
||||
-- along with the related source location so that we can display the error
|
||||
-- on either the console or in the IDE at the right source location.
|
||||
--
|
||||
type FileDiagnostics = (FilePath, [Diagnostic])
|
||||
type FileDiagnostic = (FilePath, Diagnostic)
|
||||
type FileDiagnostics = (NormalizedFilePath, [Diagnostic])
|
||||
type FileDiagnostic = (NormalizedFilePath, Diagnostic)
|
||||
|
||||
prettyRange :: Range -> Doc SyntaxClass
|
||||
prettyRange Range{..} = f _start <> "-" <> f _end
|
||||
@ -152,7 +182,7 @@ prettyDiagnostics = vcat . map prettyDiagnostic
|
||||
prettyDiagnostic :: FileDiagnostic -> Doc SyntaxClass
|
||||
prettyDiagnostic (fp, LSP.Diagnostic{..}) =
|
||||
vcat
|
||||
[ slabel_ "File: " $ pretty fp
|
||||
[ slabel_ "File: " $ pretty (fromNormalizedFilePath fp)
|
||||
, slabel_ "Range: " $ prettyRange _range
|
||||
, slabel_ "Source: " $ pretty _source
|
||||
, slabel_ "Severity:" $ pretty $ show sev
|
||||
@ -185,7 +215,7 @@ emptyDiagnostics = ProjectDiagnostics mempty
|
||||
-- if you want to clear the diagnostics call this with an empty list
|
||||
setStageDiagnostics ::
|
||||
Show stage =>
|
||||
FilePath ->
|
||||
NormalizedFilePath ->
|
||||
Maybe Int ->
|
||||
-- ^ the time that the file these diagnostics originate from was last edited
|
||||
stage ->
|
||||
@ -198,8 +228,8 @@ setStageDiagnostics fp timeM stage diags (ProjectDiagnostics ds) =
|
||||
diagsBySource = Map.singleton (Just $ T.pack $ show stage) (SL.toSortedList diags)
|
||||
uri = filePathToUri' fp
|
||||
|
||||
fromUri :: LSP.NormalizedUri -> FilePath
|
||||
fromUri = fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri
|
||||
fromUri :: LSP.NormalizedUri -> NormalizedFilePath
|
||||
fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri
|
||||
|
||||
getAllDiagnostics ::
|
||||
ProjectDiagnostics stage ->
|
||||
@ -208,7 +238,7 @@ getAllDiagnostics =
|
||||
concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList . getStore
|
||||
|
||||
getFileDiagnostics ::
|
||||
FilePath ->
|
||||
NormalizedFilePath ->
|
||||
ProjectDiagnostics stage ->
|
||||
[LSP.Diagnostic]
|
||||
getFileDiagnostics fp ds =
|
||||
@ -217,10 +247,10 @@ getFileDiagnostics fp ds =
|
||||
getStore ds
|
||||
|
||||
filterDiagnostics ::
|
||||
(FilePath -> Bool) ->
|
||||
(NormalizedFilePath -> Bool) ->
|
||||
ProjectDiagnostics stage ->
|
||||
ProjectDiagnostics stage
|
||||
filterDiagnostics keep =
|
||||
ProjectDiagnostics .
|
||||
Map.filterWithKey (\uri _ -> maybe True keep $ uriToFilePath' $ fromNormalizedUri uri) .
|
||||
Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri) .
|
||||
getStore
|
||||
|
||||
@ -10,7 +10,7 @@ module Development.IDE.Types.LSP
|
||||
|
||||
import Control.DeepSeq
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.Types.Diagnostics (uriToFilePath')
|
||||
import Development.IDE.Types.Diagnostics
|
||||
import GHC.Generics
|
||||
import Language.Haskell.LSP.Messages
|
||||
import Language.Haskell.LSP.Types
|
||||
@ -30,9 +30,9 @@ getHoverTextContent = \case
|
||||
|
||||
-- | Virtual resources
|
||||
data VirtualResource = VRScenario
|
||||
{ vrScenarioFile :: !FilePath
|
||||
{ vrScenarioFile :: !NormalizedFilePath
|
||||
, vrScenarioName :: !T.Text
|
||||
} deriving (Eq, Ord, Read, Show, Generic)
|
||||
} deriving (Eq, Ord, Show, Generic)
|
||||
-- ^ VRScenario identifies a scenario in a given file.
|
||||
-- This virtual resource is associated with the HTML result of
|
||||
-- interpreting the corresponding scenario.
|
||||
|
||||
@ -35,7 +35,7 @@ import GHC.Paths
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
(ghcOptions, files) <- getCmdLine
|
||||
(ghcOptions, map toNormalizedFilePath -> files) <- getCmdLine
|
||||
|
||||
-- lock to avoid overlapping output on stdout
|
||||
lock <- newLock
|
||||
@ -66,7 +66,7 @@ main = do
|
||||
-- | Print an LSP event.
|
||||
showEvent :: Lock -> FromServerMessage -> IO ()
|
||||
showEvent _ (EventFileDiagnostics _ []) = return ()
|
||||
showEvent lock (EventFileDiagnostics file diags) =
|
||||
showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
|
||||
withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags
|
||||
showEvent lock e = withLock lock $ print e
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user