41d693a · ghcide · git.iko.soy

git.iko.soy/ghcide

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.

commit41d693ad0354eb932e6164d05bec058959461d11 authorMoritz Kiefer <moritz.kiefer@purelyfunctional.org> dateThu 13 Jun 2019, 15:11 (7 years ago) parent3fd52a8

12 files changed+135−101

compare with master

unifiedsplit

src/Development/IDE/Functions/Compile.hs+1−1

@@ -92,7 +92,7 @@ getSrcSpanInfos

9292 :: IdeOptions

9393 -> ParsedModule

9494 -> HscEnv

95− -> [(Located ModuleName, Maybe FilePath)]

95+ -> [(Located ModuleName, Maybe NormalizedFilePath)]

9696 -> TcModuleResult

9797 -> IO [SpanInfo]

9898getSrcSpanInfos opt mod env imports tc =

src/Development/IDE/Functions/DependencyInformation.hs+22−20

@@ -36,20 +36,20 @@ import Module

3636

3737-- | Unprocessed results that we get from following all imports recursively starting from a module.

3838data RawDependencyInformation = RawDependencyInformation

39− { moduleDependencies :: Map FilePath (Either ModuleParseError [(Located ModuleName, Maybe FilePath)])

40− , pkgDependencies :: Map FilePath (Set InstalledUnitId)

39+ { moduleDependencies :: Map NormalizedFilePath (Either ModuleParseError [(Located ModuleName, Maybe NormalizedFilePath)])

40+ , pkgDependencies :: Map NormalizedFilePath (Set InstalledUnitId)

4141 -- ^ Transitive dependencies on pkgs of this file, i.e. immidiate package dependencies and the

4242 -- transitive package dependencies of those packages.

4343 }

4444

4545data DependencyInformation =

4646 DependencyInformation

47− { depErrorNodes :: Map FilePath (NonEmpty NodeError)

47+ { depErrorNodes :: Map NormalizedFilePath (NonEmpty NodeError)

4848 -- ^ Nodes that cannot be processed correctly.

49− , depModuleDeps :: Map FilePath (Set FilePath)

49+ , depModuleDeps :: Map NormalizedFilePath (Set NormalizedFilePath)

5050 -- ^ For a non-error node, this contains the set of module immediate dependencies

5151 -- in the same package.

52− , depPkgDeps :: Map FilePath (Set InstalledUnitId)

52+ , depPkgDeps :: Map NormalizedFilePath (Set InstalledUnitId)

5353 -- ^ For a non-error node, this contains the set of immediate pkg deps.

5454 } deriving (Show, Generic)

5555

@@ -69,7 +69,7 @@ instance NFData LocateError

6969

7070-- | An error attached to a node in the dependency graph.

7171data NodeError

72− = PartOfCycle (Located ModuleName) [FilePath]

72+ = PartOfCycle (Located ModuleName) [NormalizedFilePath]

7373 -- ^ This module is part of an import cycle. The module name corresponds

7474 -- to the import that enters the cycle starting from this module.

7575 -- The list of filepaths represents the elements

@@ -94,10 +94,12 @@ instance NFData NodeError where

9494-- `ErrorNode`. Otherwise it is a `SuccessNode`.

9595data NodeResult

9696 = ErrorNode (NonEmpty NodeError)

97− | SuccessNode [(Located ModuleName, FilePath)]

97+ | SuccessNode [(Located ModuleName, NormalizedFilePath)]

9898 deriving Show

9999

100−partitionNodeResults :: [(a, NodeResult)] -> ([(a, NonEmpty NodeError)], [(a, [(Located ModuleName, FilePath)])])

100+partitionNodeResults

101+ :: [(a, NodeResult)]

102+ -> ([(a, NonEmpty NodeError)], [(a, [(Located ModuleName, NormalizedFilePath)])])

101103partitionNodeResults = partitionEithers . map f

102104 where f (a, ErrorNode errs) = Left (a, errs)

103105 f (a, SuccessNode imps) = Right (a, imps)

@@ -116,7 +118,7 @@ processDependencyInformation rawResults =

116118 , depPkgDeps = pkgDependencies rawResults

117119 }

118120 where resultGraph = buildResultGraph rawResults

119− successEdges :: [(FilePath, FilePath, [FilePath])]

121+ successEdges :: [(NormalizedFilePath, NormalizedFilePath, [NormalizedFilePath])]

120122 successEdges = map (\(k,ks) -> (k,k,ks)) $ MS.toList $

121123 MS.map (map snd) $ MS.mapMaybe successNode resultGraph

122124 moduleDeps =

@@ -131,22 +133,22 @@ processDependencyInformation rawResults =

131133-- 2. Mark each node that has a parse error as an error node.

132134-- 3. Mark each node whose immediate children could not be located as an error.

133135-- 4. Recursively propagate errors to parents if they are not already error nodes.

134−buildResultGraph :: RawDependencyInformation -> Map FilePath NodeResult

136+buildResultGraph :: RawDependencyInformation -> Map NormalizedFilePath NodeResult

135137buildResultGraph g = propagatedErrors

136138 where

137139 sccs = stronglyConnComp (graphEdges g)

138140 (_, cycles) = partitionSCC sccs

139− cycleErrors :: Map FilePath NodeResult

141+ cycleErrors :: Map NormalizedFilePath NodeResult

140142 cycleErrors = MS.unionsWith (<>) $ map errorsForCycle cycles

141− errorsForCycle :: [FilePath] -> Map FilePath NodeResult

143+ errorsForCycle :: [NormalizedFilePath] -> Map NormalizedFilePath NodeResult

142144 errorsForCycle files =

143145 MS.fromListWith (<>) (concatMap (cycleErrorsForFile files) files)

144− cycleErrorsForFile :: [FilePath] -> FilePath -> [(FilePath,NodeResult)]

146+ cycleErrorsForFile :: [NormalizedFilePath] -> NormalizedFilePath -> [(NormalizedFilePath,NodeResult)]

145147 cycleErrorsForFile cycle f =

146148 let entryPoints = mapMaybe (findImport f) cycle

147149 in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints

148150 otherErrors = MS.map otherErrorsForFile (moduleDependencies g)

149− otherErrorsForFile :: Either ModuleParseError [(Located ModuleName, Maybe FilePath)] -> NodeResult

151+ otherErrorsForFile :: Either ModuleParseError [(Located ModuleName, Maybe NormalizedFilePath)] -> NodeResult

150152 otherErrorsForFile (Left err) = ErrorNode (ParseError err :| [])

151153 otherErrorsForFile (Right imports) =

152154 let toEither (imp, Nothing) = Left imp

@@ -171,17 +173,17 @@ buildResultGraph g = propagatedErrors

171173 in case nonEmpty errs of

172174 Nothing -> n

173175 Just errs' -> ErrorNode (NonEmpty.map (ParentOfErrorNode . fst) errs')

174− findImport :: FilePath -> FilePath -> Maybe (Located ModuleName)

176+ findImport :: NormalizedFilePath -> NormalizedFilePath -> Maybe (Located ModuleName)

175177 findImport file importedFile =

176178 case moduleDependencies g MS.! file of

177179 Left _ -> error "Tried to call findImport on a module with a parse error"

178180 Right imports ->

179181 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) imports

180182

181−graphEdges :: RawDependencyInformation -> [(FilePath, FilePath, [FilePath])]

183+graphEdges :: RawDependencyInformation -> [(NormalizedFilePath, NormalizedFilePath, [NormalizedFilePath])]

182184graphEdges g =

183185 map (\(k, ks) -> (k, k, ks)) $ MS.toList $ MS.map deps $ moduleDependencies g

184− where deps :: Either e [(i, Maybe FilePath)] -> [FilePath]

186+ where deps :: Either e [(i, Maybe NormalizedFilePath)] -> [NormalizedFilePath]

185187 deps (Left _) = []

186188 deps (Right imports) = mapMaybe snd imports

187189

@@ -190,17 +192,17 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest

190192partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest

191193partitionSCC [] = ([], [])

192194

193−transitiveDeps :: DependencyInformation -> FilePath -> Maybe TransitiveDependencies

195+transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies

194196transitiveDeps DependencyInformation{..} f = do

195197 reachableVs <- Set.delete f . Set.fromList . map (fst3 . fromVertex) . reachable g <$> toVertex f

196198 let transitiveModuleDeps = filter (\v -> v `Set.member` reachableVs) $ map (fst3 . fromVertex) vs

197199 let transitivePkgDeps = Set.toList $ foldMap (\f -> MS.findWithDefault Set.empty f depPkgDeps) (f : transitiveModuleDeps)

198− pure $ TransitiveDependencies {..}

200+ pure TransitiveDependencies {..}

199201 where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, Set.toList fs)) $ MS.toList depModuleDeps)

200202 vs = topSort g

201203

202204data TransitiveDependencies = TransitiveDependencies

203− { transitiveModuleDeps :: [FilePath]

205+ { transitiveModuleDeps :: [NormalizedFilePath]

204206 -- ^ Transitive module dependencies in topological order.

205207 -- The module itself is not included.

206208 , transitivePkgDeps :: [InstalledUnitId]

src/Development/IDE/Functions/FindImports.hs+6−5

@@ -11,6 +11,7 @@ module Development.IDE.Functions.FindImports

1111

1212import Development.IDE.Functions.GHCError as ErrUtils

1313import Development.IDE.Orphans()

14+import Development.IDE.Types.Diagnostics

1415-- GHC imports

1516import BasicTypes (StringLiteral(..))

1617import DynFlags

@@ -30,7 +31,7 @@ import qualified Control.Monad.Trans.Except as Ex

3031import System.FilePath

3132

3233data Import

33− = FileImport FilePath

34+ = FileImport NormalizedFilePath

3435 | PackageImport M.InstalledUnitId

3536 deriving (Show)

3637

@@ -67,11 +68,11 @@ getImportsParsed dflags (L loc parsed) = do

6768locateModuleFile :: MonadIO m

6869 => DynFlags

6970 -> [String]

70− -> (FilePath -> m Bool)

71+ -> (NormalizedFilePath -> m Bool)

7172 -> ModuleName

72− -> m (Maybe FilePath)

73+ -> m (Maybe NormalizedFilePath)

7374locateModuleFile dflags exts doesExist modName = do

74− let candidates = [ prefix </> M.moduleNameSlashes modName <.> ext | prefix <- importPaths dflags, ext <- exts]

75+ let candidates = [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> ext) | prefix <- importPaths dflags, ext <- exts]

7576 findM doesExist candidates

7677

7778-- | locate a module in either the file system or the package database. Where we go from *daml to

@@ -80,7 +81,7 @@ locateModule

8081 :: MonadIO m

8182 => DynFlags

8283 -> [String]

83− -> (FilePath -> m Bool)

84+ -> (NormalizedFilePath -> m Bool)

8485 -> Located ModuleName

8586 -> Maybe FastString

8687 -> m (Either [FileDiagnostic] Import)

src/Development/IDE/Functions/GHCError.hs+2−2

@@ -50,7 +50,7 @@ mkDiag dflags src e =

5050 case toDSeverity $ errMsgSeverity e of

5151 Nothing -> Nothing

5252 Just bSeverity ->

53− Just $ (srcSpanToFilename $ errMsgSpan e,)

53+ Just $ (toNormalizedFilePath $ srcSpanToFilename (errMsgSpan e),)

5454 Diagnostic

5555 { _range = srcSpanToRange $ errMsgSpan e

5656 , _severity = Just bSeverity

@@ -78,7 +78,7 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real

7878

7979srcSpanToLocation :: SrcSpan -> Location

8080srcSpanToLocation src =

81− Location (fromNormalizedUri $ D.filePathToUri' $ srcSpanToFilename src) (srcSpanToRange src)

81+ Location (filePathToUri $ srcSpanToFilename src) (srcSpanToRange src)

8282

8383-- | Convert a GHC severity to a DAML compiler Severity. Severities below

8484-- "Warning" level are dropped (returning Nothing).

src/Development/IDE/Functions/SpanInfo.hs+7−6

@@ -21,6 +21,7 @@ import Desugar

2121import GHC

2222import GhcMonad

2323import FastString (mkFastString)

24+import Development.IDE.Types.Diagnostics

2425import Development.IDE.Types.SpanInfo

2526import Development.IDE.Functions.GHCError (zeroSpan)

2627import Prelude hiding (mod)

@@ -29,7 +30,7 @@ import Var

2930

3031-- | Get ALL source spans in the module.

3132getSpanInfo :: GhcMonad m

32− => [(Located ModuleName, Maybe FilePath)] -- ^ imports

33+ => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports

3334 -> TypecheckedModule

3435 -> m [SpanInfo]

3536getSpanInfo mods tcm =

@@ -94,17 +95,17 @@ getTypeLPat _ pat =

9495 (Named (dataConName dc), spn)

9596 getSpanSource _ = (NoSource, noSrcSpan)

9697

97−importInfo :: [(Located ModuleName, Maybe FilePath)]

98+importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]

9899 -> [(SpanSource, SrcSpan, Maybe Type)]

99100importInfo = mapMaybe (uncurry wrk) where

100− wrk :: Located ModuleName -> Maybe FilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)

101+ wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)

101102 wrk modName = \case

102103 Nothing -> Nothing

103− Just afp -> Just (afpToSpanSource afp, getLoc modName, Nothing)

104+ Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName, Nothing)

104105

105106 -- TODO make this point to the module name

106− afpToSpanSource :: FilePath -> SpanSource

107− afpToSpanSource afp = Span $ RealSrcSpan $ zeroSpan $ mkFastString afp

107+ fpToSpanSource :: FilePath -> SpanSource

108+ fpToSpanSource fp = Span $ RealSrcSpan $ zeroSpan $ mkFastString fp

108109

109110-- | Get ALL source spans in the source.

110111listifyAllSpans :: Typeable a

src/Development/IDE/State/FileStore.hs+10−8

@@ -97,7 +97,7 @@ getFileExistsRule vfs =

9797 alwaysRerun

9898 res <- liftIO $ handle (\(_ :: IOException) -> return False) $

9999 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^

100− Dir.doesFileExist file

100+ Dir.doesFileExist (fromNormalizedFilePath file)

101101 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))

102102

103103

@@ -107,14 +107,16 @@ showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicos

107107getModificationTimeRule :: VFSHandle -> Rules ()

108108getModificationTimeRule vfs =

109109 defineEarlyCutoff $ \GetModificationTime file -> do

110+ let file' = fromNormalizedFilePath file

110111 let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just $ ModificationTime time))

111112 alwaysRerun

112113 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file

113114 case mbVirtual of

114115 Just (VirtualFile ver _ _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))

115− Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file) `catch` \(e :: IOException) -> do

116− let err | isDoesNotExistError e = "File does not exist: " ++ file

117− | otherwise = "IO error while reading " ++ file ++ ", " ++ displayException e

116+ Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file')

117+ `catch` \(e :: IOException) -> do

118+ let err | isDoesNotExistError e = "File does not exist: " ++ file'

119+ | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e

118120 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))

119121

120122

@@ -127,16 +129,16 @@ getFileContentsRule vfs =

127129 mbVirtual <- getVirtualFile vfs $ filePathToUri' file

128130 case mbVirtual of

129131 Just (VirtualFile _ rope _) -> return $ textToStringBuffer $ Rope.toText rope

130− Nothing -> hGetStringBuffer file

132+ Nothing -> hGetStringBuffer (fromNormalizedFilePath file)

131133 case res of

132134 Left err -> return ([err], Nothing)

133135 Right contents -> return ([], Just (time, contents))

134136

135137

136−getFileContents :: FilePath -> Action (FileVersion, StringBuffer)

138+getFileContents :: NormalizedFilePath -> Action (FileVersion, StringBuffer)

137139getFileContents = use_ GetFileContents

138140

139−getFileExists :: FilePath -> Action Bool

141+getFileExists :: NormalizedFilePath -> Action Bool

140142getFileExists =

141143 -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute

142144 -- 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

153155

154156

155157-- | Notify the compiler service of a modified buffer

156−setBufferModified :: IdeState -> FilePath -> Maybe T.Text -> IO ()

158+setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()

157159setBufferModified state absFile mbContents = do

158160 VFSHandle{..} <- getIdeGlobalState state

159161 case mbContents of

src/Development/IDE/State/Rules.hs+17−20

@@ -74,41 +74,38 @@ defineNoFile f = define $ \k file -> do

7474

7575

7676-- | Get GHC Core for the supplied file.

77−getGhcCore :: FilePath -> Action (Maybe [CoreModule])

77+getGhcCore :: NormalizedFilePath -> Action (Maybe [CoreModule])

7878getGhcCore file = eitherToMaybe <$> runExceptT (coresForFile file)

7979

8080-- | Generate the GHC Core for the supplied file and its dependencies.

81−coresForFile :: FilePath -> ExceptT [FileDiagnostic] Action [CoreModule]

81+coresForFile :: NormalizedFilePath -> ExceptT [FileDiagnostic] Action [CoreModule]

8282coresForFile file = do

8383 files <- transitiveModuleDeps <$> useE GetDependencies file

8484 pms <- usesE GetParsedModule $ files ++ [file]

85− fs <- liftIO

86− . mapM fileFromParsedModule

87− $ pms

88− cores <- usesE GenerateCore fs

85+ cores <- usesE GenerateCore $ map fileFromParsedModule pms

8986 pure (map Compile.gmCore cores)

9087

9188

9289

9390-- | Get all transitive file dependencies of a given module.

9491-- Does not include the file itself.

95−getDependencies :: FilePath -> Action (Maybe [FilePath])

92+getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])

9693getDependencies file =

9794 eitherToMaybe <$>

9895 (runExceptT $ transitiveModuleDeps <$> useE GetDependencies file)

9996

100−getDalfDependencies :: FilePath -> Action (Maybe [InstalledUnitId])

97+getDalfDependencies :: NormalizedFilePath -> Action (Maybe [InstalledUnitId])

10198getDalfDependencies file =

10299 eitherToMaybe <$>

103100 (runExceptT $ transitivePkgDeps <$> useE GetDependencies file)

104101

105102-- | Documentation at point.

106−getAtPoint :: FilePath -> Position -> Action (Maybe (Maybe Range, [HoverText]))

103+getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [HoverText]))

107104getAtPoint file pos = do

108105 fmap (either (const Nothing) id) . runExceptT $ getAtPointForFile file pos

109106

110107-- | Goto Definition.

111−getDefinition :: FilePath -> Position -> Action (Maybe Location)

108+getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)

112109getDefinition file pos = do

113110 fmap (either (const Nothing) id) . runExceptT $ getDefinitionForFile file pos

114111

@@ -118,18 +115,18 @@ getDefinition file pos = do

118115

119116useE

120117 :: IdeRule k v

121− => k -> FilePath -> ExceptT [FileDiagnostic] Action v

118+ => k -> NormalizedFilePath -> ExceptT [FileDiagnostic] Action v

122119useE k = ExceptT . fmap toIdeResultSilent . use k

123120

124121-- picks the first error

125122usesE

126123 :: IdeRule k v

127− => k -> [FilePath] -> ExceptT [FileDiagnostic] Action [v]

124+ => k -> [NormalizedFilePath] -> ExceptT [FileDiagnostic] Action [v]

128125usesE k = ExceptT . fmap (mapM toIdeResultSilent) . uses k

129126

130127-- | Try to get hover text for the name under point.

131128getAtPointForFile

132− :: FilePath

129+ :: NormalizedFilePath

133130 -> Position

134131 -> ExceptT [FileDiagnostic] Action (Maybe (Maybe Range, [HoverText]))

135132getAtPointForFile file pos = do

@@ -138,7 +135,7 @@ getAtPointForFile file pos = do

138135 spans <- useE GetSpanInfo file

139136 return $ AtPoint.atPoint (map Compile.tmrModule tms) spans pos

140137

141−getDefinitionForFile :: FilePath -> Position -> ExceptT [FileDiagnostic] Action (Maybe Location)

138+getDefinitionForFile :: NormalizedFilePath -> Position -> ExceptT [FileDiagnostic] Action (Maybe Location)

142139getDefinitionForFile file pos = do

143140 spans <- useE GetSpanInfo file

144141 pkgState <- useE GhcSession ""

@@ -167,7 +164,7 @@ getParsedModuleRule =

167164 (_, contents) <- getFileContents file

168165 packageState <- use_ GhcSession ""

169166 opt <- getOpts

170− liftIO $ Compile.parseModule opt packageState file contents

167+ liftIO $ Compile.parseModule opt packageState (fromNormalizedFilePath file) contents

171168

172169getLocatedImportsRule :: Rules ()

173170getLocatedImportsRule =

@@ -185,7 +182,7 @@ getLocatedImportsRule =

185182

186183-- | Given a target file path, construct the raw dependency results by following

187184-- imports recursively.

188−rawDependencyInformation :: FilePath -> ExceptT [FileDiagnostic] Action RawDependencyInformation

185+rawDependencyInformation :: NormalizedFilePath -> ExceptT [FileDiagnostic] Action RawDependencyInformation

189186rawDependencyInformation f = go (Set.singleton f) Map.empty Map.empty

190187 where go fs !modGraph !pkgs =

191188 case Set.minView fs of

@@ -242,7 +239,7 @@ reportImportCyclesRule =

242239 , _relatedInformation = Nothing

243240 }

244241 where loc = srcSpanToLocation (getLoc imp)

245− fp = srcSpanToFilename (getLoc imp)

242+ fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)

246243 getModuleName file = do

247244 pm <- useE GetParsedModule file

248245 pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)

@@ -324,12 +321,12 @@ mainRule = do

324321

325322------------------------------------------------------------

326323

327−fileFromParsedModule :: ParsedModule -> IO FilePath

328−fileFromParsedModule = pure . ms_hspp_file . pm_mod_summary

324+fileFromParsedModule :: ParsedModule -> NormalizedFilePath

325+fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary

329326

330327fileImports ::

331328 [(Located ModuleName, Maybe Import)]

332− -> [(Located ModuleName, Maybe FilePath)]

329+ -> [(Located ModuleName, Maybe NormalizedFilePath)]

333330fileImports = mapMaybe $ \case

334331 (modName, Nothing) -> Just (modName, Nothing)

335332 (modName, Just (FileImport absFile)) -> Just (modName, Just absFile)

src/Development/IDE/State/Service.hs+3−2

@@ -27,6 +27,7 @@ import qualified Development.IDE.Logger as Logger

2727import Data.Set (Set)

2828import qualified Data.Set as Set

2929import Development.IDE.Functions.GHCError

30+import Development.IDE.Types.Diagnostics (NormalizedFilePath)

3031import Development.Shake hiding (Diagnostic, Env, newCache)

3132import qualified Language.Haskell.LSP.Messages as LSP

3233

@@ -39,7 +40,7 @@ import Development.IDE.State.Shake

3940data Env = Env

4041 { envOptions :: IdeOptions

4142 -- ^ Compiler options.

42− , envOfInterestVar :: Var (Set FilePath)

43+ , envOfInterestVar :: Var (Set NormalizedFilePath)

4344 -- ^ The files of interest.

4445 , envUniqSupplyVar :: Var UniqSupply

4546 -- ^ The unique supply of names used by the compiler.

@@ -107,7 +108,7 @@ runActions x = join . shakeRun x

107108

108109

109110-- | Set the files-of-interest which will be built and kept-up-to-date.

110−setFilesOfInterest :: IdeState -> Set FilePath -> IO ()

111+setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()

111112setFilesOfInterest state files = do

112113 Env{..} <- getIdeGlobalState state

113114 -- update vars synchronously

src/Development/IDE/State/Shake.hs+16−16

@@ -119,7 +119,7 @@ getIdeGlobalState = getIdeGlobalExtras . shakeExtras

119119

120120

121121-- | The state of the all values - nested so you can easily find all errors at a given file.

122−type Values = Map.HashMap (FilePath, Key) (Maybe Dynamic)

122+type Values = Map.HashMap (NormalizedFilePath, Key) (Maybe Dynamic)

123123

124124-- | Key type

125125data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k

@@ -195,7 +195,7 @@ profileCounter = unsafePerformIO $ newVar 0

195195setValues :: IdeRule k v

196196 => Var Values

197197 -> k

198− -> FilePath

198+ -> NormalizedFilePath

199199 -> Maybe v

200200 -> IO ()

201201setValues state key file val = modifyVar_ state $

@@ -204,7 +204,7 @@ setValues state key file val = modifyVar_ state $

204204-- | The outer Maybe is Nothing if this function hasn't been computed before

205205-- the inner Maybe is Nothing if the result of the previous computation failed to produce

206206-- a value

207−getValues :: forall k v. IdeRule k v => Var Values -> k -> FilePath -> IO (Maybe (Maybe v))

207+getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Maybe v))

208208getValues state key file = do

209209 vs <- readVar state

210210 return $ do

@@ -255,7 +255,7 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts = modifyVar shakeAbort $

255255-- | Use the last stale value, if it's ever been computed.

256256useStale

257257 :: IdeRule k v

258− => IdeState -> k -> FilePath -> IO (Maybe v)

258+ => IdeState -> k -> NormalizedFilePath -> IO (Maybe v)

259259useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =

260260 join <$> getValues state k fp

261261

@@ -271,7 +271,7 @@ unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =

271271 writeVar diagnostics emptyDiagnostics

272272

273273-- | Clear the results for all files that do not match the given predicate.

274−garbageCollect :: (FilePath -> Bool) -> Action ()

274+garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()

275275garbageCollect keep = do

276276 ShakeExtras{state, diagnostics} <- getShakeExtras

277277 liftIO $

@@ -280,17 +280,17 @@ garbageCollect keep = do

280280

281281define

282282 :: IdeRule k v

283− => (k -> FilePath -> Action (IdeResult v)) -> Rules ()

283+ => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()

284284define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v

285285

286286use :: IdeRule k v

287− => k -> FilePath -> Action (Maybe v)

287+ => k -> NormalizedFilePath -> Action (Maybe v)

288288use key file = head <$> uses key [file]

289289

290−use_ :: IdeRule k v => k -> FilePath -> Action v

290+use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v

291291use_ key file = head <$> uses_ key [file]

292292

293−uses_ :: IdeRule k v => k -> [FilePath] -> Action [v]

293+uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]

294294uses_ key files = do

295295 res <- uses key files

296296 case sequence res of

@@ -321,7 +321,7 @@ isBadDependency x

321321 | otherwise = False

322322

323323

324−newtype Q k = Q (k, FilePath)

324+newtype Q k = Q (k, NormalizedFilePath)

325325 deriving (Eq,Hashable,NFData)

326326

327327-- Using Database we don't need Binary instances for keys

@@ -330,7 +330,7 @@ instance Binary (Q k) where

330330 get = fail "Binary.get not defined for type Development.IDE.State.Shake.Q"

331331

332332instance Show k => Show (Q k) where

333− show (Q (k, file)) = show k ++ "; " ++ file

333+ show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file

334334

335335-- | Invariant: the 'v' must be in normal form (fully evaluated).

336336-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database

@@ -346,12 +346,12 @@ type instance RuleResult (Q k) = A (RuleResult k)

346346

347347-- | Compute the value

348348uses :: IdeRule k v

349− => k -> [FilePath] -> Action [Maybe v]

349+ => k -> [NormalizedFilePath] -> Action [Maybe v]

350350uses key files = map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)

351351

352352defineEarlyCutoff

353353 :: IdeRule k v

354− => (k -> FilePath -> Action (Maybe BS.ByteString, IdeResult v))

354+ => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))

355355 -> Rules ()

356356defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do

357357 extras@ShakeExtras{state} <- getShakeExtras

@@ -383,7 +383,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old m

383383 unwrap x = if BS.null x then Nothing else Just $ BS.tail x

384384

385385updateFileDiagnostics ::

386− FilePath

386+ NormalizedFilePath

387387 -> Key

388388 -> ShakeExtras

389389 -> [Diagnostic] -- ^ current results

@@ -397,13 +397,13 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, state} current = do

397397 let newDiags = getFileDiagnostics fp newDiagsStore

398398 pure (newDiagsStore, (newDiags, oldDiags))

399399 when (newDiags /= oldDiags) $

400− sendEvent $ publishDiagnosticsNotification fp newDiags

400+ sendEvent $ publishDiagnosticsNotification (fromNormalizedFilePath fp) newDiags

401401

402402publishDiagnosticsNotification :: FilePath -> [Diagnostic] -> LSP.FromServerMessage

403403publishDiagnosticsNotification fp diags =

404404 LSP.NotPublishDiagnostics $

405405 LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $

406− LSP.PublishDiagnosticsParams (fromNormalizedUri $ filePathToUri' fp) (List diags)

406+ LSP.PublishDiagnosticsParams (LSP.filePathToUri fp) (List diags)

407407

408408setPriority :: (Enum a) => a -> Action ()

409409setPriority p =

src/Development/IDE/Types/Diagnostics.hs+46−16

@@ -21,6 +21,9 @@ module Development.IDE.Types.Diagnostics (

2121 NormalizedUri,

2222 LSP.toNormalizedUri,

2323 LSP.fromNormalizedUri,

24+ NormalizedFilePath,

25+ toNormalizedFilePath,

26+ fromNormalizedFilePath,

2427 noLocation,

2528 noRange,

2629 noFilePath,

@@ -31,6 +34,7 @@ module Development.IDE.Types.Diagnostics (

3134 showDiagnostics,

3235 showDiagnosticsColored,

3336 defDiagnostic,

37+ filePathToUri,

3438 filePathToUri',

3539 uriToFilePath',

3640 ProjectDiagnostics,

@@ -42,14 +46,18 @@ module Development.IDE.Types.Diagnostics (

4246 prettyDiagnostics

4347 ) where

4448

49+import Control.DeepSeq

4550import Control.Exception

4651import Data.Either.Combinators

4752import Data.Maybe as Maybe

4853import Data.Foldable

54+import Data.Hashable

4955import qualified Data.Map as Map

56+import Data.String

5057import qualified Data.Text as T

5158import Data.Text.Prettyprint.Doc.Syntax

5259import qualified Data.SortedList as SL

60+import System.FilePath

5361import qualified Text.PrettyPrint.Annotated.HughesPJClass as Pretty

5462import qualified Language.Haskell.LSP.Types as LSP

5563import Language.Haskell.LSP.Types as LSP (

@@ -67,6 +75,26 @@ import Language.Haskell.LSP.Diagnostics

6775

6876import Development.IDE.Types.Location

6977

78+-- | Newtype wrapper around FilePath that always has normalized slashes.

79+newtype NormalizedFilePath = NormalizedFilePath FilePath

80+ deriving (Eq, Ord, Show, Hashable, NFData)

81+

82+instance IsString NormalizedFilePath where

83+ fromString = toNormalizedFilePath

84+

85+toNormalizedFilePath :: FilePath -> NormalizedFilePath

86+toNormalizedFilePath "" = NormalizedFilePath ""

87+toNormalizedFilePath fp = NormalizedFilePath $ normalise' fp

88+ where

89+ -- We do not use System.FilePath’s normalise here since that

90+ -- also normalises things like the case of the drive letter

91+ -- which NormalizedUri does not normalise so we get VFS lookup failures.

92+ normalise' :: FilePath -> FilePath

93+ normalise' = map (\c -> if isPathSeparator c then pathSeparator else c)

94+

95+fromNormalizedFilePath :: NormalizedFilePath -> FilePath

96+fromNormalizedFilePath (NormalizedFilePath fp) = fp

97+

7098-- | We use an empty string as a filepath when we don’t have a file.

7199-- However, haskell-lsp doesn’t support that in uriToFilePath and given

72100-- that it is not a valid filepath it does not make sense to upstream a fix.

@@ -76,16 +104,16 @@ uriToFilePath' uri

76104 | uri == filePathToUri "" = Just ""

77105 | otherwise = LSP.uriToFilePath uri

78106

79−filePathToUri' :: FilePath -> NormalizedUri

80−filePathToUri' fp = toNormalizedUri $ filePathToUri fp

107+filePathToUri' :: NormalizedFilePath -> NormalizedUri

108+filePathToUri' = toNormalizedUri . filePathToUri . fromNormalizedFilePath

81109

82−ideErrorText :: FilePath -> T.Text -> FileDiagnostic

110+ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic

83111ideErrorText fp = errorDiag fp "Ide Error"

84112

85−ideErrorPretty :: Pretty.Pretty e => FilePath -> e -> FileDiagnostic

113+ideErrorPretty :: Pretty.Pretty e => NormalizedFilePath -> e -> FileDiagnostic

86114ideErrorPretty fp = ideErrorText fp . T.pack . Pretty.prettyShow

87115

88−errorDiag :: FilePath -> T.Text -> T.Text -> FileDiagnostic

116+errorDiag :: NormalizedFilePath -> T.Text -> T.Text -> FileDiagnostic

89117errorDiag fp src msg =

90118 (fp, diagnostic noRange LSP.DsError src msg)

91119

@@ -119,9 +147,11 @@ defDiagnostic _range _message = LSP.Diagnostic {

119147 , _relatedInformation = Nothing

120148 }

121149

122−ideTryIOException :: FilePath -> IO a -> IO (Either FileDiagnostic a)

150+ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)

123151ideTryIOException fp act =

124− mapLeft (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e) <$> try act

152+ mapLeft

153+ (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)

154+ <$> try act

125155

126156-- | Human readable diagnostics for a specific file.

127157--

@@ -129,8 +159,8 @@ ideTryIOException fp act =

129159-- along with the related source location so that we can display the error

130160-- on either the console or in the IDE at the right source location.

131161--

132−type FileDiagnostics = (FilePath, [Diagnostic])

133−type FileDiagnostic = (FilePath, Diagnostic)

162+type FileDiagnostics = (NormalizedFilePath, [Diagnostic])

163+type FileDiagnostic = (NormalizedFilePath, Diagnostic)

134164

135165prettyRange :: Range -> Doc SyntaxClass

136166prettyRange Range{..} = f _start <> "-" <> f _end

@@ -152,7 +182,7 @@ prettyDiagnostics = vcat . map prettyDiagnostic

152182prettyDiagnostic :: FileDiagnostic -> Doc SyntaxClass

153183prettyDiagnostic (fp, LSP.Diagnostic{..}) =

154184 vcat

155− [ slabel_ "File: " $ pretty fp

185+ [ slabel_ "File: " $ pretty (fromNormalizedFilePath fp)

156186 , slabel_ "Range: " $ prettyRange _range

157187 , slabel_ "Source: " $ pretty _source

158188 , slabel_ "Severity:" $ pretty $ show sev

@@ -185,7 +215,7 @@ emptyDiagnostics = ProjectDiagnostics mempty

185215-- if you want to clear the diagnostics call this with an empty list

186216setStageDiagnostics ::

187217 Show stage =>

188− FilePath ->

218+ NormalizedFilePath ->

189219 Maybe Int ->

190220 -- ^ the time that the file these diagnostics originate from was last edited

191221 stage ->

@@ -198,8 +228,8 @@ setStageDiagnostics fp timeM stage diags (ProjectDiagnostics ds) =

198228 diagsBySource = Map.singleton (Just $ T.pack $ show stage) (SL.toSortedList diags)

199229 uri = filePathToUri' fp

200230

201−fromUri :: LSP.NormalizedUri -> FilePath

202−fromUri = fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri

231+fromUri :: LSP.NormalizedUri -> NormalizedFilePath

232+fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri

203233

204234getAllDiagnostics ::

205235 ProjectDiagnostics stage ->

@@ -208,7 +238,7 @@ getAllDiagnostics =

208238 concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList . getStore

209239

210240getFileDiagnostics ::

211− FilePath ->

241+ NormalizedFilePath ->

212242 ProjectDiagnostics stage ->

213243 [LSP.Diagnostic]

214244getFileDiagnostics fp ds =

@@ -217,10 +247,10 @@ getFileDiagnostics fp ds =

217247 getStore ds

218248

219249filterDiagnostics ::

220− (FilePath -> Bool) ->

250+ (NormalizedFilePath -> Bool) ->

221251 ProjectDiagnostics stage ->

222252 ProjectDiagnostics stage

223253filterDiagnostics keep =

224254 ProjectDiagnostics .

225− Map.filterWithKey (\uri _ -> maybe True keep $ uriToFilePath' $ fromNormalizedUri uri) .

255+ Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri) .

226256 getStore

src/Development/IDE/Types/LSP.hs+3−3

@@ -10,7 +10,7 @@ module Development.IDE.Types.LSP

1010

1111import Control.DeepSeq

1212import qualified Data.Text as T

13−import Development.IDE.Types.Diagnostics (uriToFilePath')

13+import Development.IDE.Types.Diagnostics

1414import GHC.Generics

1515import Language.Haskell.LSP.Messages

1616import Language.Haskell.LSP.Types

@@ -30,9 +30,9 @@ getHoverTextContent = \case

3030

3131-- | Virtual resources

3232data VirtualResource = VRScenario

33− { vrScenarioFile :: !FilePath

33+ { vrScenarioFile :: !NormalizedFilePath

3434 , vrScenarioName :: !T.Text

35− } deriving (Eq, Ord, Read, Show, Generic)

35+ } deriving (Eq, Ord, Show, Generic)

3636 -- ^ VRScenario identifies a scenario in a given file.

3737 -- This virtual resource is associated with the HTML result of

3838 -- interpreting the corresponding scenario.

test/Demo.hs+2−2

@@ -35,7 +35,7 @@ import GHC.Paths

3535

3636main :: IO ()

3737main = do

38− (ghcOptions, files) <- getCmdLine

38+ (ghcOptions, map toNormalizedFilePath -> files) <- getCmdLine

3939

4040 -- lock to avoid overlapping output on stdout

4141 lock <- newLock

@@ -66,7 +66,7 @@ main = do

6666-- | Print an LSP event.

6767showEvent :: Lock -> FromServerMessage -> IO ()

6868showEvent _ (EventFileDiagnostics _ []) = return ()

69−showEvent lock (EventFileDiagnostics file diags) =

69+showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =

7070 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags

7171showEvent lock e = withLock lock $ print e

7272