From be63c39d0d4428eafd45beaa580415e41b589417 Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Thu, 13 Jun 2019 15:11:47 +0200 Subject: [PATCH] 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. --- .../src/Development/IDE/Functions/Compile.hs | 2 +- .../IDE/Functions/DependencyInformation.hs | 42 +++++++------ .../Development/IDE/Functions/FindImports.hs | 11 ++-- .../src/Development/IDE/Functions/GHCError.hs | 4 +- .../src/Development/IDE/Functions/SpanInfo.hs | 13 ++-- .../src/Development/IDE/State/FileStore.hs | 18 +++--- .../src/Development/IDE/State/Rules.hs | 37 +++++------ .../src/Development/IDE/State/Service.hs | 5 +- .../src/Development/IDE/State/Shake.hs | 32 +++++----- .../src/Development/IDE/Types/Diagnostics.hs | 62 ++++++++++++++----- .../src/Development/IDE/Types/LSP.hs | 6 +- compiler/haskell-ide-core/test/Demo.hs | 4 +- .../src/DA/Service/Daml/Compiler/Impl/Dar.hs | 21 ++++--- .../DA/Service/Daml/Compiler/Impl/Handle.hs | 27 ++++---- daml-foundations/daml-ghc/damldoc/BUILD.bazel | 1 + .../damldoc/src/DA/Daml/GHC/Damldoc/Driver.hs | 6 +- .../src/DA/Daml/GHC/Damldoc/HaddockParse.hs | 4 +- .../damldoc/test/DA/Daml/GHC/Damldoc/Tests.hs | 3 +- .../src/DA/Daml/GHC/Compiler/Convert.hs | 2 +- .../Development/IDE/State/RuleTypes/Daml.hs | 7 ++- .../src/Development/IDE/State/Rules/Daml.hs | 44 ++++++------- .../src/Development/IDE/State/Service/Daml.hs | 3 +- .../test/Development/IDE/State/API/Testing.hs | 45 +++++++------- .../src/DA/Service/Daml/LanguageServer.hs | 12 ++-- .../Service/Daml/LanguageServer/CodeLens.hs | 4 +- .../Service/Daml/LanguageServer/Definition.hs | 4 +- .../DA/Service/Daml/LanguageServer/Hover.hs | 4 +- .../daml-ghc/test-src/DA/Test/GHC.hs | 17 ++--- .../test-src/DA/Test/ShakeIdeClient.hs | 3 +- .../daml-tools/da-hs-daml-cli/BUILD.bazel | 1 + .../daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs | 12 ++-- .../DA/Cli/Damlc/Command/Damldoc.hs | 3 +- .../da-hs-daml-cli/DA/Cli/Damlc/Test.hs | 20 +++--- .../da-hs-daml-cli/tests/DamlcTest.hs | 5 +- 34 files changed, 266 insertions(+), 218 deletions(-) diff --git a/compiler/haskell-ide-core/src/Development/IDE/Functions/Compile.hs b/compiler/haskell-ide-core/src/Development/IDE/Functions/Compile.hs index 695ae3fd92..c2c7d42e41 100644 --- a/compiler/haskell-ide-core/src/Development/IDE/Functions/Compile.hs +++ b/compiler/haskell-ide-core/src/Development/IDE/Functions/Compile.hs @@ -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 = diff --git a/compiler/haskell-ide-core/src/Development/IDE/Functions/DependencyInformation.hs b/compiler/haskell-ide-core/src/Development/IDE/Functions/DependencyInformation.hs index b41ed75634..2956d21e49 100644 --- a/compiler/haskell-ide-core/src/Development/IDE/Functions/DependencyInformation.hs +++ b/compiler/haskell-ide-core/src/Development/IDE/Functions/DependencyInformation.hs @@ -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] diff --git a/compiler/haskell-ide-core/src/Development/IDE/Functions/FindImports.hs b/compiler/haskell-ide-core/src/Development/IDE/Functions/FindImports.hs index 576e41041d..ba04e65a82 100644 --- a/compiler/haskell-ide-core/src/Development/IDE/Functions/FindImports.hs +++ b/compiler/haskell-ide-core/src/Development/IDE/Functions/FindImports.hs @@ -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) diff --git a/compiler/haskell-ide-core/src/Development/IDE/Functions/GHCError.hs b/compiler/haskell-ide-core/src/Development/IDE/Functions/GHCError.hs index b36abd9861..77beb783b9 100644 --- a/compiler/haskell-ide-core/src/Development/IDE/Functions/GHCError.hs +++ b/compiler/haskell-ide-core/src/Development/IDE/Functions/GHCError.hs @@ -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). diff --git a/compiler/haskell-ide-core/src/Development/IDE/Functions/SpanInfo.hs b/compiler/haskell-ide-core/src/Development/IDE/Functions/SpanInfo.hs index aede813ae8..1cb331fba9 100644 --- a/compiler/haskell-ide-core/src/Development/IDE/Functions/SpanInfo.hs +++ b/compiler/haskell-ide-core/src/Development/IDE/Functions/SpanInfo.hs @@ -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 diff --git a/compiler/haskell-ide-core/src/Development/IDE/State/FileStore.hs b/compiler/haskell-ide-core/src/Development/IDE/State/FileStore.hs index 943fa21634..497bd326b6 100644 --- a/compiler/haskell-ide-core/src/Development/IDE/State/FileStore.hs +++ b/compiler/haskell-ide-core/src/Development/IDE/State/FileStore.hs @@ -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 diff --git a/compiler/haskell-ide-core/src/Development/IDE/State/Rules.hs b/compiler/haskell-ide-core/src/Development/IDE/State/Rules.hs index e41aca18d8..8bd522de40 100644 --- a/compiler/haskell-ide-core/src/Development/IDE/State/Rules.hs +++ b/compiler/haskell-ide-core/src/Development/IDE/State/Rules.hs @@ -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) diff --git a/compiler/haskell-ide-core/src/Development/IDE/State/Service.hs b/compiler/haskell-ide-core/src/Development/IDE/State/Service.hs index ecc1170229..ff0e173a70 100644 --- a/compiler/haskell-ide-core/src/Development/IDE/State/Service.hs +++ b/compiler/haskell-ide-core/src/Development/IDE/State/Service.hs @@ -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 diff --git a/compiler/haskell-ide-core/src/Development/IDE/State/Shake.hs b/compiler/haskell-ide-core/src/Development/IDE/State/Shake.hs index a4aa22d7e5..b3ffa2e1c8 100644 --- a/compiler/haskell-ide-core/src/Development/IDE/State/Shake.hs +++ b/compiler/haskell-ide-core/src/Development/IDE/State/Shake.hs @@ -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 = diff --git a/compiler/haskell-ide-core/src/Development/IDE/Types/Diagnostics.hs b/compiler/haskell-ide-core/src/Development/IDE/Types/Diagnostics.hs index 7d2ae35a11..817409d3ea 100644 --- a/compiler/haskell-ide-core/src/Development/IDE/Types/Diagnostics.hs +++ b/compiler/haskell-ide-core/src/Development/IDE/Types/Diagnostics.hs @@ -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 diff --git a/compiler/haskell-ide-core/src/Development/IDE/Types/LSP.hs b/compiler/haskell-ide-core/src/Development/IDE/Types/LSP.hs index b30821591a..e043c2cf6a 100644 --- a/compiler/haskell-ide-core/src/Development/IDE/Types/LSP.hs +++ b/compiler/haskell-ide-core/src/Development/IDE/Types/LSP.hs @@ -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. diff --git a/compiler/haskell-ide-core/test/Demo.hs b/compiler/haskell-ide-core/test/Demo.hs index bef9dfc575..38026e7258 100644 --- a/compiler/haskell-ide-core/test/Demo.hs +++ b/compiler/haskell-ide-core/test/Demo.hs @@ -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 diff --git a/daml-foundations/daml-ghc/daml-compiler/src/DA/Service/Daml/Compiler/Impl/Dar.hs b/daml-foundations/daml-ghc/daml-compiler/src/DA/Service/Daml/Compiler/Impl/Dar.hs index af37ab0138..fd796f74d3 100644 --- a/daml-foundations/daml-ghc/daml-compiler/src/DA/Service/Daml/Compiler/Impl/Dar.hs +++ b/daml-foundations/daml-ghc/daml-compiler/src/DA/Service/Daml/Compiler/Impl/Dar.hs @@ -17,6 +17,7 @@ import System.FilePath import System.Directory import qualified Codec.Archive.Zip as Zip import DA.Daml.GHC.Compiler.Options +import Development.IDE.Types.Diagnostics ------------------------------------------------------------------------------ {- | Builds a dar file. @@ -46,9 +47,9 @@ gernerated separately. buildDar :: BSL.ByteString - -> FilePath + -> NormalizedFilePath -> [(T.Text, BS.ByteString)] - -> [FilePath] + -> [NormalizedFilePath] -> [(String, BS.ByteString)] -> String -> String @@ -57,19 +58,21 @@ buildDar dalf modRoot dalfDependencies fileDependencies dataFiles name sdkVersio -- Take all source file dependencies and produced interface files. Only the new package command -- produces interface files per default, hence we filter for existent files. ifaces <- + fmap (map toNormalizedFilePath) $ filterM doesFileExist $ - concat [[ifaceDir dep -<.> "hi", ifaceDir dep -<.> "hie"] | dep <- fileDependencies] + concat [[ifaceDir dep -<.> "hi", ifaceDir dep -<.> "hie"] | dep <- map fromNormalizedFilePath fileDependencies] -- Reads all module source files, and pairs paths (with changed prefix) -- with contents as BS. The path must be within the module root path, and -- is modified to have prefix instead of the original root path. srcFiles <- forM fileDependencies $ \mPath -> do - contents <- BSL.readFile mPath - return (name makeRelative' modRoot mPath, contents) + contents <- BSL.readFile $ fromNormalizedFilePath mPath + return (name fromNormalizedFilePath (makeRelative' modRoot mPath), contents) ifaceFaceFiles <- forM ifaces $ \mPath -> do - contents <- BSL.readFile mPath - return (name makeRelative' (ifaceDir modRoot) mPath, contents) + contents <- BSL.readFile $ fromNormalizedFilePath mPath + let ifaceRoot = toNormalizedFilePath (ifaceDir fromNormalizedFilePath modRoot) + return (name fromNormalizedFilePath (makeRelative' ifaceRoot mPath), contents) let dalfName = name <> ".dalf" let dependencies = [(T.unpack pkgName <> ".dalf", BSC.fromStrict bs) @@ -112,5 +115,5 @@ buildDar dalf modRoot dalfDependencies fileDependencies dataFiles name sdkVersio -- instead of -- -- > makeRelative "./a" "a/b" == "a/b" -makeRelative' :: FilePath -> FilePath -> FilePath -makeRelative' a b = makeRelative (normalise a) (normalise b) +makeRelative' :: NormalizedFilePath -> NormalizedFilePath -> NormalizedFilePath +makeRelative' a b = toNormalizedFilePath $ makeRelative (fromNormalizedFilePath a) (fromNormalizedFilePath b) diff --git a/daml-foundations/daml-ghc/daml-compiler/src/DA/Service/Daml/Compiler/Impl/Handle.hs b/daml-foundations/daml-ghc/daml-compiler/src/DA/Service/Daml/Compiler/Impl/Handle.hs index 392d73d1d1..82a7b625dc 100644 --- a/daml-foundations/daml-ghc/daml-compiler/src/DA/Service/Daml/Compiler/Impl/Handle.hs +++ b/daml-foundations/daml-ghc/daml-compiler/src/DA/Service/Daml/Compiler/Impl/Handle.hs @@ -124,7 +124,7 @@ toIdeLogger h = IdeLogger.Handle { -- | Update the files-of-interest, which we recieve asynchronous notifications for. setFilesOfInterest :: IdeState - -> [FilePath] + -> [NormalizedFilePath] -> IO () setFilesOfInterest service files = do CompilerService.logDebug service $ "Setting files of interest to: " <> T.pack (show files) @@ -140,7 +140,7 @@ setOpenVirtualResources service vrs = do getAssociatedVirtualResources :: IdeState - -> FilePath + -> NormalizedFilePath -> IO [(Base.Range, T.Text, VirtualResource)] getAssociatedVirtualResources service filePath = do mod0 <- runExceptT $ do @@ -164,7 +164,7 @@ getAssociatedVirtualResources service filePath = do gotoDefinition :: IdeState - -> FilePath + -> NormalizedFilePath -> Base.Position -> IO (Maybe Base.Location) gotoDefinition service afp pos = do @@ -173,7 +173,7 @@ gotoDefinition service afp pos = do atPoint :: IdeState - -> FilePath + -> NormalizedFilePath -> Base.Position -> IO (Maybe (Maybe Base.Range, [HoverText])) atPoint service afp pos = do @@ -186,14 +186,14 @@ compileFile :: IdeState -- -> Options -- -> Bool -- ^ collect and display warnings - -> FilePath + -> NormalizedFilePath -> ExceptT [FileDiagnostic] IO LF.Package compileFile service fp = do -- We need to mark the file we are compiling as a file of interest. -- Otherwise all diagnostics produced during compilation will be garbage -- collected afterwards. liftIO $ setFilesOfInterest service [fp] - liftIO $ CompilerService.logDebug service $ "Compiling: " <> T.pack fp + liftIO $ CompilerService.logDebug service $ "Compiling: " <> T.pack (fromNormalizedFilePath fp) res <- liftIO $ CompilerService.runAction service (CompilerService.getDalf fp) case res of Nothing -> do @@ -204,7 +204,7 @@ compileFile service fp = do -- | Manages the file store (caching compilation results and unsaved content). onFileModified :: IdeState - -> FilePath + -> NormalizedFilePath -> Maybe T.Text -> IO () onFileModified service fp mbContents = do @@ -215,7 +215,7 @@ newtype UseDalf = UseDalf{unUseDalf :: Bool} buildDar :: IdeState - -> FilePath + -> NormalizedFilePath -> Maybe [String] -> String -> String @@ -228,15 +228,16 @@ buildDar :: -> UseDalf -> ExceptT [FileDiagnostic] IO BS.ByteString buildDar service file mbExposedModules pkgName sdkVersion buildDataFiles dalfInput = do + let file' = fromNormalizedFilePath file liftIO $ CompilerService.logDebug service $ - "Creating dar: " <> T.pack file + "Creating dar: " <> T.pack file' if unUseDalf dalfInput then liftIO $ do - bytes <- BSL.readFile file + bytes <- BSL.readFile file' Dar.buildDar bytes - (takeDirectory file) + (toNormalizedFilePath $ takeDirectory file') [] [] [] @@ -269,7 +270,7 @@ buildDar service file mbExposedModules pkgName sdkVersion buildDataFiles dalfInp liftIO $ Dar.buildDar dalf - (takeDirectory file) + (toNormalizedFilePath $ takeDirectory file') dalfDependencies (file:fileDependencies) (buildDataFiles pkg) @@ -278,7 +279,7 @@ buildDar service file mbExposedModules pkgName sdkVersion buildDataFiles dalfInp -- | Get the transitive package dependencies on other dalfs. getDalfDependencies :: - IdeState -> FilePath -> ExceptT [FileDiagnostic] IO [DalfDependency] + IdeState -> NormalizedFilePath -> ExceptT [FileDiagnostic] IO [DalfDependency] getDalfDependencies service afp = do res <- liftIO $ diff --git a/daml-foundations/daml-ghc/damldoc/BUILD.bazel b/daml-foundations/daml-ghc/damldoc/BUILD.bazel index 67a606bd4b..eca758dfec 100644 --- a/daml-foundations/daml-ghc/damldoc/BUILD.bazel +++ b/daml-foundations/daml-ghc/damldoc/BUILD.bazel @@ -56,6 +56,7 @@ da_haskell_library( src_strip_prefix = "test", visibility = ["//visibility:public"], deps = [ + "//compiler/haskell-ide-core", "//daml-foundations/daml-ghc/damldoc", "//daml-foundations/daml-ghc/ghc-compiler", "//daml-foundations/daml-ghc/test-lib", diff --git a/daml-foundations/daml-ghc/damldoc/src/DA/Daml/GHC/Damldoc/Driver.hs b/daml-foundations/daml-ghc/damldoc/src/DA/Daml/GHC/Damldoc/Driver.hs index f6e2b1f3cc..fa219196d3 100644 --- a/daml-foundations/daml-ghc/damldoc/src/DA/Daml/GHC/Damldoc/Driver.hs +++ b/daml-foundations/daml-ghc/damldoc/src/DA/Daml/GHC/Damldoc/Driver.hs @@ -36,12 +36,12 @@ damlDocDriver :: InputFormat -> DocFormat -> Maybe FilePath -> [DocOption] - -> [FilePath] + -> [NormalizedFilePath] -> IO () damlDocDriver cInputFormat output cFormat prefixFile options files = do let printAndExit errMsg = do - putStrLn $ "Error processing input from " <> unwords files <> "\n" + putStrLn $ "Error processing input from " <> unwords (map fromNormalizedFilePath files) <> "\n" <> errMsg fail "Aborted." @@ -51,7 +51,7 @@ damlDocDriver cInputFormat output cFormat prefixFile options files = do docData <- case cInputFormat of InputJson -> do - input <- mapM BS.readFile files + input <- mapM (BS.readFile . fromNormalizedFilePath) files let mbData = map AE.eitherDecode input :: [Either String [ModuleDoc]] concatMapM (either printAndExit pure) mbData diff --git a/daml-foundations/daml-ghc/damldoc/src/DA/Daml/GHC/Damldoc/HaddockParse.hs b/daml-foundations/daml-ghc/damldoc/src/DA/Daml/GHC/Damldoc/HaddockParse.hs index dac761e998..eba20cb54e 100644 --- a/daml-foundations/daml-ghc/damldoc/src/DA/Daml/GHC/Damldoc/HaddockParse.hs +++ b/daml-foundations/daml-ghc/damldoc/src/DA/Daml/GHC/Damldoc/HaddockParse.hs @@ -31,7 +31,7 @@ import Data.Tuple.Extra (second) -- | Parse, and process documentation in, a dependency graph of modules. mkDocs :: IdeOptions -> - [FilePath] -> + [NormalizedFilePath] -> Ex.ExceptT [FileDiagnostic] IO [ModuleDoc] mkDocs opts fp = do parsed <- haddockParse opts fp @@ -118,7 +118,7 @@ collectDocs = go Nothing [] -- Not using the cached file store, as it is expected to run stand-alone -- invoked by a CLI tool. haddockParse :: IdeOptions -> - [FilePath] -> + [NormalizedFilePath] -> Ex.ExceptT [FileDiagnostic] IO [ParsedModule] haddockParse opts f = ExceptT $ do vfs <- makeVFSHandle diff --git a/daml-foundations/daml-ghc/damldoc/test/DA/Daml/GHC/Damldoc/Tests.hs b/daml-foundations/daml-ghc/damldoc/test/DA/Daml/GHC/Damldoc/Tests.hs index 2cc69b0ce4..24e726d54e 100644 --- a/daml-foundations/daml-ghc/damldoc/test/DA/Daml/GHC/Damldoc/Tests.hs +++ b/daml-foundations/daml-ghc/damldoc/test/DA/Daml/GHC/Damldoc/Tests.hs @@ -12,6 +12,7 @@ import DA.Daml.GHC.Damldoc.HaddockParse import DA.Daml.GHC.Damldoc.Render import DA.Daml.GHC.Damldoc.Types import DA.Test.Util +import Development.IDE.Types.Diagnostics import Control.Monad.Except import qualified Data.Aeson.Encode.Pretty as AP @@ -227,7 +228,7 @@ damldocExpect testname input check = opts <- defaultOptionsIO Nothing -- run the doc generator on that file - mbResult <- runExceptT $ mkDocs (toCompileOpts opts) [testfile] + mbResult <- runExceptT $ mkDocs (toCompileOpts opts) [toNormalizedFilePath testfile] case mbResult of Left err -> assertFailure $ unlines diff --git a/daml-foundations/daml-ghc/ghc-compiler/src/DA/Daml/GHC/Compiler/Convert.hs b/daml-foundations/daml-ghc/ghc-compiler/src/DA/Daml/GHC/Compiler/Convert.hs index 0932aac342..de16e08c76 100644 --- a/daml-foundations/daml-ghc/ghc-compiler/src/DA/Daml/GHC/Compiler/Convert.hs +++ b/daml-foundations/daml-ghc/ghc-compiler/src/DA/Daml/GHC/Compiler/Convert.hs @@ -122,7 +122,7 @@ conversionError :: String -> ConvertM e conversionError msg = do ConversionEnv{..} <- ask let addFpIfExists = - (fromMaybe noFilePath convModuleFilePath,) + (toNormalizedFilePath $ fromMaybe noFilePath convModuleFilePath,) throwError $ addFpIfExists $ Diagnostic { _range = maybe noRange sourceLocToRange convRange , _severity = Just DsError diff --git a/daml-foundations/daml-ghc/ide/src/Development/IDE/State/RuleTypes/Daml.hs b/daml-foundations/daml-ghc/ide/src/Development/IDE/State/RuleTypes/Daml.hs index 3687e39570..32af20e09a 100644 --- a/daml-foundations/daml-ghc/ide/src/Development/IDE/State/RuleTypes/Daml.hs +++ b/daml-foundations/daml-ghc/ide/src/Development/IDE/State/RuleTypes/Daml.hs @@ -23,6 +23,7 @@ import Development.Shake import GHC.Generics (Generic) import "ghc-lib-parser" Module (UnitId) +import Development.IDE.Types.Diagnostics import Development.IDE.Types.LSP import Development.IDE.State.RuleTypes @@ -51,16 +52,16 @@ type instance RuleResult CreateScenarioContext = SS.ContextId -- used for executing scenarios in A. We use this when running the scenarios -- in transitive dependencies of the files of interest so that we only need -- one scenario context per file of interest. -type instance RuleResult GetScenarioRoots = Map FilePath FilePath +type instance RuleResult GetScenarioRoots = Map NormalizedFilePath NormalizedFilePath -- ^ The root for the given file based on GetScenarioRoots. -- This is a separate rule so we can avoid rerunning scenarios if -- only the roots of other files have changed. -type instance RuleResult GetScenarioRoot = FilePath +type instance RuleResult GetScenarioRoot = NormalizedFilePath -- | These rules manage access to the global state in -- envOfInterestVar and envOpenVirtualResources. -type instance RuleResult GetFilesOfInterest = Set FilePath +type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath type instance RuleResult GetOpenVirtualResources = Set VirtualResource data GenerateDalf = GenerateDalf diff --git a/daml-foundations/daml-ghc/ide/src/Development/IDE/State/Rules/Daml.hs b/daml-foundations/daml-ghc/ide/src/Development/IDE/State/Rules/Daml.hs index d6e62c3330..22ed89da23 100644 --- a/daml-foundations/daml-ghc/ide/src/Development/IDE/State/Rules/Daml.hs +++ b/daml-foundations/daml-ghc/ide/src/Development/IDE/State/Rules/Daml.hs @@ -76,7 +76,7 @@ virtualResourceToUri virtualResourceToUri vr = case vr of VRScenario filePath topLevelDeclName -> T.pack $ "daml://compiler?" <> keyValueToQueryString - [ ("file", filePath) + [ ("file", fromNormalizedFilePath filePath) , ("top-level-decl", T.unpack topLevelDeclName) ] where @@ -98,7 +98,7 @@ uriToVirtualResource uri = do let decoded = queryString uri file <- Map.lookup "file" decoded topLevelDecl <- Map.lookup "top-level-decl" decoded - pure $ VRScenario file (T.pack topLevelDecl) + pure $ VRScenario (toNormalizedFilePath file) (T.pack topLevelDecl) _ -> Nothing where @@ -115,19 +115,19 @@ uriToVirtualResource uri = do -- | Get an unvalidated DALF package. -- This must only be used for debugging/testing. -getRawDalf :: FilePath -> Action (Maybe LF.Package) +getRawDalf :: NormalizedFilePath -> Action (Maybe LF.Package) getRawDalf absFile = use GenerateRawPackage absFile -- | Get a validated DALF package. -getDalf :: FilePath -> Action (Maybe LF.Package) +getDalf :: NormalizedFilePath -> Action (Maybe LF.Package) getDalf file = eitherToMaybe <$> (runExceptT $ useE GeneratePackage file) -runScenarios :: FilePath -> Action (Maybe [(VirtualResource, Either SS.Error SS.ScenarioResult)]) +runScenarios :: NormalizedFilePath -> Action (Maybe [(VirtualResource, Either SS.Error SS.ScenarioResult)]) runScenarios file = use RunScenarios file -- | Get a list of the scenarios in a given file -getScenarioNames :: FilePath -> Action (Maybe [VirtualResource]) +getScenarioNames :: NormalizedFilePath -> Action (Maybe [VirtualResource]) getScenarioNames file = fmap f <$> use GenerateRawDalf file where f = map (VRScenario file . LF.unExprValName . LF.qualObject) . scenariosInModule @@ -186,7 +186,7 @@ generatePackageMap fps = do dalfBS <- BS.readFile dalf return $ do (pkgId, package) <- - mapLeft (ideErrorPretty dalf) $ + mapLeft (ideErrorPretty $ toNormalizedFilePath dalf) $ Archive.decodeArchive dalfBS let unitId = stringToUnitId $ dropExtension $ takeFileName dalf Right (unitId, (pkgId, package, dalfBS, dalf)) @@ -234,7 +234,7 @@ generatePackageDepsRule options = -- build package return ([], Just $ buildPackage (optMbPackageName options) lfVersion dalfs) -contextForFile :: FilePath -> Action SS.Context +contextForFile :: NormalizedFilePath -> Action SS.Context contextForFile file = do lfVersion <- getDamlLfVersion pkg <- use_ GeneratePackage file @@ -252,7 +252,7 @@ contextForFile file = do ScenarioValidationLight -> SS.LightValidation True } -worldForFile :: FilePath -> Action LF.World +worldForFile :: NormalizedFilePath -> Action LF.World worldForFile file = do pkg <- use_ GeneratePackage file pkgMap <- use_ GeneratePackageMap "" @@ -286,7 +286,7 @@ createScenarioContextRule = -- for generating modules that are sent to the scenario service. -- It switches between GenerateRawDalf and GenerateDalf depending -- on whether we only do light or full validation. -dalfForScenario :: FilePath -> Action LF.Module +dalfForScenario :: NormalizedFilePath -> Action LF.Module dalfForScenario file = do DamlEnv{..} <- getDamlServiceEnv case envScenarioValidation of @@ -326,7 +326,7 @@ encodeModule :: LF.Version -> LF.Module -> Action (SS.Hash, BS.ByteString) encodeModule lfVersion m = case LF.moduleSource m of Just file - | isAbsolute file -> use_ EncodeModule file + | isAbsolute file -> use_ EncodeModule $ toNormalizedFilePath file _ -> pure $ SS.encodeModule lfVersion m getScenarioRootsRule :: Rules () @@ -348,8 +348,8 @@ getScenarioRootRule = ctxRoots <- use_ GetScenarioRoots "" case Map.lookup file ctxRoots of Nothing -> liftIO $ - fail $ "No scenario root for file " <> show file <> "." - Just root -> pure (Just $ BS.fromString root, ([], Just root)) + fail $ "No scenario root for file " <> show (fromNormalizedFilePath file) <> "." + Just root -> pure (Just $ BS.fromString $ fromNormalizedFilePath root, ([], Just root)) -- | Virtual resource changed notification @@ -417,7 +417,7 @@ ofInterestRule = do [runScenarios file | shouldRunScenarios, file <- Set.toList scenarioFiles] return () where - gc :: Set FilePath -> Action () + gc :: Set NormalizedFilePath -> Action () gc roots = do depInfoOrErr <- sequence <$> uses GetDependencyInformation (Set.toList roots) -- We only clear results if there are no errors in the @@ -445,7 +445,7 @@ ofInterestRule = do getFilesOfInterestRule :: Rules () getFilesOfInterestRule = do - defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null _file) $ do + defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do alwaysRerun Env{..} <- getServiceEnv filesOfInterest <- liftIO $ readVar envOfInterestVar @@ -453,7 +453,7 @@ getFilesOfInterestRule = do getOpenVirtualResourcesRule :: Rules () getOpenVirtualResourcesRule = do - defineEarlyCutoff $ \GetOpenVirtualResources _file -> assert (null _file) $ do + defineEarlyCutoff $ \GetOpenVirtualResources _file -> assert (null $ fromNormalizedFilePath _file) $ do alwaysRerun DamlEnv{..} <- getDamlServiceEnv openVRs <- liftIO $ readVar envOpenVirtualResources @@ -474,7 +474,7 @@ formatScenarioResult world errOrRes = Right res -> LF.renderScenarioResult world res -runScenario :: SS.Handle -> FilePath -> SS.ContextId -> LF.ValueRef -> IO (VirtualResource, Either SS.Error SS.ScenarioResult) +runScenario :: SS.Handle -> NormalizedFilePath -> SS.ContextId -> LF.ValueRef -> IO (VirtualResource, Either SS.Error SS.ScenarioResult) runScenario scenarioService file ctxId scenario = do res <- SS.runScenario scenarioService ctxId scenario let scenarioName = LF.qualObject scenario @@ -500,11 +500,11 @@ scenariosInModule m = getDamlLfVersion:: Action LF.Version getDamlLfVersion = envDamlLfVersion <$> getDamlServiceEnv -discardInternalModules :: [FilePath] -> Action [FilePath] -discardInternalModules files = - mapM (liftIO . fileFromParsedModule) . - filter (not . modIsInternal . ms_mod . pm_mod_summary) =<< - uses_ GetParsedModule files +discardInternalModules :: [NormalizedFilePath] -> Action [NormalizedFilePath] +discardInternalModules files = do + mods <- uses_ GetParsedModule files + pure $ map fileFromParsedModule $ + filter (not . modIsInternal . ms_mod . pm_mod_summary) mods internalModules :: [String] internalModules = diff --git a/daml-foundations/daml-ghc/ide/src/Development/IDE/State/Service/Daml.hs b/daml-foundations/daml-ghc/ide/src/Development/IDE/State/Service/Daml.hs index d2e6454692..b788dc89bb 100644 --- a/daml-foundations/daml-ghc/ide/src/Development/IDE/State/Service/Daml.hs +++ b/daml-foundations/daml-ghc/ide/src/Development/IDE/State/Service/Daml.hs @@ -26,6 +26,7 @@ import Development.IDE.State.Service hiding (initialise) import Development.IDE.State.FileStore import qualified Development.IDE.State.Service as IDE import Development.IDE.State.Shake +import Development.IDE.Types.Diagnostics import Development.IDE.Types.LSP import qualified Language.Haskell.LSP.Messages as LSP @@ -36,7 +37,7 @@ import qualified DA.Daml.LF.ScenarioServiceClient as SS data DamlEnv = DamlEnv { envScenarioService :: Maybe SS.Handle , envOpenVirtualResources :: Var (Set VirtualResource) - , envScenarioContexts :: Var (Map FilePath SS.ContextId) + , envScenarioContexts :: Var (Map NormalizedFilePath SS.ContextId) -- ^ This is a map from the file for which the context was created to -- the context id. We use this to track which scenario contexts -- are active so that we can GC inactive scenarios. diff --git a/daml-foundations/daml-ghc/ide/test/Development/IDE/State/API/Testing.hs b/daml-foundations/daml-ghc/ide/test/Development/IDE/State/API/Testing.hs index 3caab016b9..c82914ab1f 100644 --- a/daml-foundations/daml-ghc/ide/test/Development/IDE/State/API/Testing.hs +++ b/daml-foundations/daml-ghc/ide/test/Development/IDE/State/API/Testing.hs @@ -138,19 +138,19 @@ runShakeTest mbScenarioService (ShakeTest m) = do -- | (internal) Make sure the path is relative, and it remains inside the -- temporary test directory tree, and return the corresponding absolute path. -checkRelativePath :: FilePath -> ShakeTest FilePath -checkRelativePath relPath = do +checkRelativePath :: D.NormalizedFilePath -> ShakeTest D.NormalizedFilePath +checkRelativePath (D.fromNormalizedFilePath -> relPath) = do unless (FilePath.isRelative relPath) $ throwError (ExpectedRelativePath relPath) testDirPath <- ShakeTest $ Reader.asks steTestDirPath - let path = testDirPath relPath + let path = D.toNormalizedFilePath $ testDirPath relPath checkPath path return path -- | (internal) Make sure the path is absolute and is contained inside the -- temporary test directory tree. -checkPath :: FilePath -> ShakeTest () -checkPath relPath = ShakeTest $ do +checkPath :: D.NormalizedFilePath -> ShakeTest () +checkPath (D.fromNormalizedFilePath -> relPath) = ShakeTest $ do testDirPath <- Reader.asks steTestDirPath canPath <- liftIO $ Directory.canonicalizePath relPath unless (testDirPath `isPrefixOf` canPath) $ @@ -158,19 +158,20 @@ checkPath relPath = ShakeTest $ do -- | Make a file with given contents. -- Only call this with relative paths. -makeFile :: FilePath -> T.Text -> ShakeTest FilePath +makeFile :: D.NormalizedFilePath -> T.Text -> ShakeTest D.NormalizedFilePath makeFile relPath contents = do absPath <- checkRelativePath relPath - ShakeTest . liftIO $ Directory.createDirectoryIfMissing True $ FilePath.takeDirectory absPath - ShakeTest . liftIO $ T.IO.writeFile absPath contents + let absPath' = D.fromNormalizedFilePath absPath + ShakeTest . liftIO $ Directory.createDirectoryIfMissing True $ FilePath.takeDirectory absPath' + ShakeTest . liftIO $ T.IO.writeFile absPath' contents return absPath -- | (internal) Turn a module name into a relative file path. -moduleNameToFilePath :: String -> FilePath -moduleNameToFilePath modName = FilePath.addExtension (replace "." [FilePath.pathSeparator] modName) "daml" +moduleNameToFilePath :: String -> D.NormalizedFilePath +moduleNameToFilePath modName = D.toNormalizedFilePath $ FilePath.addExtension (replace "." [FilePath.pathSeparator] modName) "daml" -- | Similar to makeFile but including a header derived from the module name. -makeModule :: String -> [T.Text] -> ShakeTest FilePath +makeModule :: String -> [T.Text] -> ShakeTest D.NormalizedFilePath makeModule modName body = do let modPath = moduleNameToFilePath modName makeFile modPath . T.unlines $ @@ -179,7 +180,7 @@ makeModule modName body = do ] ++ body -- | Set files of interest. -setFilesOfInterest :: [FilePath] -> ShakeTest () +setFilesOfInterest :: [D.NormalizedFilePath] -> ShakeTest () setFilesOfInterest paths = do forM_ paths checkPath service <- ShakeTest $ Reader.asks steService @@ -193,15 +194,15 @@ setOpenVirtualResources vrs = do ShakeTest . liftIO $ API.setOpenVirtualResources service (Set.fromList vrs) -- | Notify compiler service that buffer is modified, with these new contents. -setBufferModified :: FilePath -> T.Text -> ShakeTest () +setBufferModified :: D.NormalizedFilePath -> T.Text -> ShakeTest () setBufferModified absPath text = setBufferModifiedMaybe absPath (Just text) -- | Notify compiler service that buffer is not modified, relative to the file on disk. -setBufferNotModified :: FilePath -> ShakeTest () +setBufferNotModified :: D.NormalizedFilePath -> ShakeTest () setBufferNotModified absPath = setBufferModifiedMaybe absPath Nothing -- | (internal) Notify compiler service that buffer is either modified or not. -setBufferModifiedMaybe :: FilePath -> Maybe T.Text -> ShakeTest () +setBufferModifiedMaybe :: D.NormalizedFilePath -> Maybe T.Text -> ShakeTest () setBufferModifiedMaybe absPath maybeText = ShakeTest $ do service <- Reader.asks steService case maybeText of @@ -269,9 +270,9 @@ getVirtualResources = ShakeTest $ do -- | Convenient grouping of file path, 0-based line number, 0-based column number. -- This isn't a record or anything because it's simple enough and generally -- easier to read as a tuple. -type Cursor = (FilePath, Int, Int) +type Cursor = (D.NormalizedFilePath, Int, Int) -cursorFilePath :: Cursor -> FilePath +cursorFilePath :: Cursor -> D.NormalizedFilePath cursorFilePath ( absPath, _line, _col) = absPath cursorPosition :: Cursor -> D.Position @@ -279,13 +280,13 @@ cursorPosition (_absPath, line, col) = D.Position line col locationStartCursor :: D.Location -> Cursor locationStartCursor (D.Location path (D.Range (D.Position line col) _)) = - (fromMaybe D.noFilePath $ D.uriToFilePath' path, line, col) + (D.toNormalizedFilePath $ fromMaybe D.noFilePath $ D.uriToFilePath' path, line, col) -- | Same as Cursor, but passing a list of columns, so you can specify a range -- such as (foo,1,[10..20]). -type CursorRange = (FilePath, Int, [Int]) +type CursorRange = (D.NormalizedFilePath, Int, [Int]) -cursorRangeFilePath :: CursorRange -> FilePath +cursorRangeFilePath :: CursorRange -> D.NormalizedFilePath cursorRangeFilePath (path, _line, _cols) = path cursorRangeList :: CursorRange -> [Cursor] @@ -309,7 +310,7 @@ searchDiagnostics expected@(severity, cursor, message) actuals = match :: D.FileDiagnostic -> Bool match (fp, d) = Just severity == D._severity d - && FilePath.normalise (cursorFilePath cursor) == FilePath.normalise fp + && cursorFilePath cursor == fp && cursorPosition cursor == D._start ((D._range :: D.Diagnostic -> Range) d) && ((standardizeQuotes $ T.toLower message) `T.isInfixOf` (standardizeQuotes $ T.toLower ((D._message :: D.Diagnostic -> T.Text) d))) @@ -393,7 +394,7 @@ matchGoToDefinitionPattern = \case l' <- l let uri = D._uri l' fp <- D.uriToFilePath' uri - pure $ isSuffixOf (moduleNameToFilePath m) fp + pure $ isSuffixOf (D.fromNormalizedFilePath $ moduleNameToFilePath m) (FilePath.normalise fp) -- | Expect "go to definition" to point us at a certain location or to fail. expectGoToDefinition :: CursorRange -> GoToDefinitionPattern -> ShakeTest () diff --git a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs index 9db16e6173..bc35f9d4bf 100644 --- a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs +++ b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs @@ -47,7 +47,7 @@ import Language.Haskell.LSP.VFS -- | Language server state data State = State - { sOpenDocuments :: !(S.Set FilePath) + { sOpenDocuments :: !(S.Set Compiler.NormalizedFilePath) , sOpenVirtualResources :: !(S.Set Compiler.VirtualResource) } @@ -107,12 +107,12 @@ handleNotification lspFuncs (IHandle stateRef loggerH compilerH) = \case let uri = _uri (docId :: VersionedTextDocumentIdentifier) case Compiler.uriToFilePath' uri of - Just filePath -> do + Just (Compiler.toNormalizedFilePath -> filePath) -> do mbVirtual <- getVirtualFileFunc lspFuncs $ toNormalizedUri uri let contents = maybe "" (Rope.toText . (_text :: VirtualFile -> Rope.Rope)) mbVirtual Compiler.onFileModified compilerH filePath (Just contents) Logger.logInfo loggerH - $ "Updated text document: " <> T.show filePath + $ "Updated text document: " <> T.show (Compiler.fromNormalizedFilePath filePath) Nothing -> Logger.logError loggerH @@ -122,7 +122,7 @@ handleNotification lspFuncs (IHandle stateRef loggerH compilerH) = \case case URI.parseURI $ T.unpack $ getUri uri of Just uri' | URI.uriScheme uri' == "file:" -> do - Just fp <- pure $ Compiler.uriToFilePath' uri + Just fp <- pure $ Compiler.toNormalizedFilePath <$> Compiler.uriToFilePath' uri handleDidCloseFile fp | URI.uriScheme uri' == "daml:" -> handleDidCloseVirtualResource uri' | otherwise -> Logger.logWarning loggerH $ "Unknown scheme in URI: " <> T.show uri @@ -141,7 +141,7 @@ handleNotification lspFuncs (IHandle stateRef loggerH compilerH) = \case -- changes in STM so that we can atomically change the state. -- Internally it should be done via the IO oracle. See PROD-2808. handleDidOpenFile (TextDocumentItem uri _ _ contents) = do - Just filePath <- pure $ Compiler.uriToFilePath' uri + Just filePath <- pure $ Compiler.toNormalizedFilePath <$> Compiler.uriToFilePath' uri documents <- atomicModifyIORef' stateRef $ \state -> let documents = S.insert filePath $ sOpenDocuments state in ( state { sOpenDocuments = documents } @@ -173,7 +173,7 @@ handleNotification lspFuncs (IHandle stateRef loggerH compilerH) = \case Compiler.setOpenVirtualResources compilerH $ S.toList resources handleDidCloseFile filePath = do - Logger.logInfo loggerH $ "Closed text document: " <> T.show filePath + Logger.logInfo loggerH $ "Closed text document: " <> T.show (Compiler.fromNormalizedFilePath filePath) documents <- atomicModifyIORef' stateRef $ \state -> let documents = S.delete filePath $ sOpenDocuments state in ( state { sOpenDocuments = documents } diff --git a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/CodeLens.hs b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/CodeLens.hs index 697dfb5ba6..06a35d4773 100644 --- a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/CodeLens.hs +++ b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/CodeLens.hs @@ -28,8 +28,8 @@ handle -> IO (List CodeLens) handle loggerH compilerH (CodeLensParams (TextDocumentIdentifier uri)) = do mbResult <- case uriToFilePath' uri of - Just filePath -> do - Logger.logInfo loggerH $ "CodeLens request for file: " <> T.pack filePath + Just (toNormalizedFilePath -> filePath) -> do + Logger.logInfo loggerH $ "CodeLens request for file: " <> T.pack (fromNormalizedFilePath filePath) vrs <- Compiler.getAssociatedVirtualResources compilerH filePath pure $ mapMaybe virtualResourceToCodeLens vrs Nothing -> pure [] diff --git a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Definition.hs b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Definition.hs index 89ac72e227..fc6c6b06a6 100644 --- a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Definition.hs +++ b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Definition.hs @@ -27,10 +27,10 @@ handle loggerH compilerH (TextDocumentPositionParams (TextDocumentIdentifier uri mbResult <- case uriToFilePath' uri of - Just filePath -> do + Just (toNormalizedFilePath -> filePath) -> do Logger.logInfo loggerH $ "Definition request at position " <> renderPlain (prettyPosition pos) - <> " in file: " <> T.pack filePath + <> " in file: " <> T.pack (fromNormalizedFilePath filePath) Compiler.gotoDefinition compilerH filePath pos Nothing -> pure Nothing diff --git a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Hover.hs b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Hover.hs index a0dec1fc8e..85f1cff5b1 100644 --- a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Hover.hs +++ b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Hover.hs @@ -29,10 +29,10 @@ handle -> IO (Maybe Hover) handle loggerH compilerH (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do mbResult <- case uriToFilePath' uri of - Just filePath -> do + Just (toNormalizedFilePath -> filePath) -> do Logger.logInfo loggerH $ "Hover request at position " <> renderPlain (prettyPosition pos) - <> " in file: " <> T.pack filePath + <> " in file: " <> T.pack (fromNormalizedFilePath filePath) Compiler.atPoint compilerH filePath pos Nothing -> pure Nothing diff --git a/daml-foundations/daml-ghc/test-src/DA/Test/GHC.hs b/daml-foundations/daml-ghc/test-src/DA/Test/GHC.hs index b97cf45cf5..2a6e3d070e 100644 --- a/daml-foundations/daml-ghc/test-src/DA/Test/GHC.hs +++ b/daml-foundations/daml-ghc/test-src/DA/Test/GHC.hs @@ -2,6 +2,7 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} -- | Test driver for DAML-GHC CompilerService. -- For each file, compile it with GHC, convert it, @@ -163,7 +164,7 @@ testCase args version getService outdir registerTODO file = singleTest file . Te } else do Compile.unsafeClearDiagnostics service - ex <- try $ mainProj args service outdir log file :: IO (Either SomeException Package) + ex <- try $ mainProj args service outdir log (toNormalizedFilePath file) :: IO (Either SomeException Package) diags <- Compile.getDiagnostics service for_ [file ++ ", " ++ x | Todo x <- anns] (registerTODO . TODO) resDiag <- checkDiagnostics log [fields | DiagnosticFields fields <- anns] $ @@ -221,7 +222,7 @@ checkDiagnostics log expected got = do | otherwise -> Just $ unlines ("Could not find matching diagnostics:" : map show bad) where checkField :: D.FileDiagnostic -> DiagnosticField -> Bool checkField (fp, D.Diagnostic{..}) f = case f of - DFilePath p -> p == fp + DFilePath p -> toNormalizedFilePath p == fp DRange r -> r == _range DSeverity s -> Just s == _severity DSource s -> Just (T.pack s) == _source @@ -299,10 +300,10 @@ parseRange s = (Position (rowEnd - 1) (colEnd - 1)) _ -> error $ "Failed to parse range, got " ++ s -mainProj :: TestArguments -> Compile.IdeState -> FilePath -> (String -> IO ()) -> FilePath -> IO LF.Package +mainProj :: TestArguments -> Compile.IdeState -> FilePath -> (String -> IO ()) -> NormalizedFilePath -> IO LF.Package mainProj TestArguments{..} service outdir log file = do writeFile <- return $ \a b -> length b `seq` writeFile a b - let proj = takeBaseName file + let proj = takeBaseName (fromNormalizedFilePath file) let corePrettyPrint = timed log "Core pretty-printing" . liftIO . writeFile (outdir proj <.> "core") . unlines . map prettyPrint let lfSave = timed log "LF saving" . liftIO . writeFileLf (outdir proj <.> "dalf") @@ -326,16 +327,16 @@ unjust act = do Nothing -> fail "_IGNORE_" Just v -> return v -ghcCompile :: (String -> IO ()) -> FilePath -> Action [GHC.CoreModule] +ghcCompile :: (String -> IO ()) -> NormalizedFilePath -> Action [GHC.CoreModule] ghcCompile log file = timed log "GHC compile" $ unjust $ Compile.getGhcCore file -lfConvert :: (String -> IO ()) -> FilePath -> Action LF.Package +lfConvert :: (String -> IO ()) -> NormalizedFilePath -> Action LF.Package lfConvert log file = timed log "LF convert" $ unjust $ Compile.getRawDalf file -lfTypeCheck :: (String -> IO ()) -> FilePath -> Action LF.Package +lfTypeCheck :: (String -> IO ()) -> NormalizedFilePath -> Action LF.Package lfTypeCheck log file = timed log "LF type check" $ unjust $ Compile.getDalf file -lfRunScenarios :: (String -> IO ()) -> FilePath -> Action () +lfRunScenarios :: (String -> IO ()) -> NormalizedFilePath -> Action () lfRunScenarios log file = timed log "LF execution" $ void $ unjust $ Compile.runScenarios file timed :: MonadIO m => (String -> IO ()) -> String -> m a -> m a diff --git a/daml-foundations/daml-ghc/test-src/DA/Test/ShakeIdeClient.hs b/daml-foundations/daml-ghc/test-src/DA/Test/ShakeIdeClient.hs index 56bd54b98d..a24af3c72e 100644 --- a/daml-foundations/daml-ghc/test-src/DA/Test/ShakeIdeClient.hs +++ b/daml-foundations/daml-ghc/test-src/DA/Test/ShakeIdeClient.hs @@ -23,6 +23,7 @@ import System.Environment.Blank (setEnv) import Control.Monad.IO.Class import DA.Service.Daml.Compiler.Impl.Scenario as SS +import Development.IDE.Types.Diagnostics import Development.IDE.Types.LSP import qualified DA.Service.Logger.Impl.Pure as Logger import Development.IDE.State.API.Testing @@ -214,7 +215,7 @@ basicTests mbScenarioService = Tasty.testGroup "Basic tests" b <- makeFile "B.daml" "daml 1.2 module B where" expectWarning (a,0,25) "The import of ‘B’ is redundant" expectNoErrors - liftIO $ removeFile b + liftIO $ removeFile (fromNormalizedFilePath b) expectOnlyDiagnostics [(DsError, (a,0,32), "Could not find module") -- the warning says around because of DEL-7199 diff --git a/daml-foundations/daml-tools/da-hs-daml-cli/BUILD.bazel b/daml-foundations/daml-tools/da-hs-daml-cli/BUILD.bazel index 1c30a4c3a1..ac2e03427a 100644 --- a/daml-foundations/daml-tools/da-hs-daml-cli/BUILD.bazel +++ b/daml-foundations/daml-tools/da-hs-daml-cli/BUILD.bazel @@ -107,6 +107,7 @@ da_haskell_test( visibility = ["//visibility:private"], deps = [ ":da-hs-daml-cli", + "//compiler/haskell-ide-core", "//daml-foundations/daml-ghc/ghc-compiler", "//libs-haskell/da-hs-base", ], diff --git a/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs b/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs index ec54f8a9ac..51c802b68a 100644 --- a/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs +++ b/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs @@ -117,10 +117,10 @@ runTestsInProjectOrFiles projectOpts Nothing color mbJUnitOutput cliOptions = project <- readProjectConfig $ ProjectPath pPath case parseProjectConfig project of Left err -> throwIO err - Right PackageConfigFields {..} -> execTest [pMain] color mbJUnitOutput cliOptions + Right PackageConfigFields {..} -> execTest [toNormalizedFilePath pMain] color mbJUnitOutput cliOptions runTestsInProjectOrFiles projectOpts (Just inFiles) color mbJUnitOutput cliOptions = withProjectRoot' projectOpts $ \relativize -> do - inFiles' <- mapM relativize inFiles + inFiles' <- mapM (fmap toNormalizedFilePath . relativize) inFiles execTest inFiles' color mbJUnitOutput cliOptions cmdInspect :: Mod CommandFields Command @@ -248,7 +248,7 @@ execCompile inputFile outputFile opts = withProjectRoot' (ProjectOpts Nothing (P inputFile <- relativize inputFile opts' <- Compiler.mkOptions opts Compiler.withIdeState opts' loggerH (const $ pure ()) $ \hDamlGhc -> do - errOrDalf <- runExceptT $ Compiler.compileFile hDamlGhc inputFile + errOrDalf <- runExceptT $ Compiler.compileFile hDamlGhc (toNormalizedFilePath inputFile) either (reportErr "DAML-1.2 to LF compilation failed") write errOrDalf where write bs @@ -365,14 +365,14 @@ execBuild projectOpts options mbOutFile initPkgDb = withProjectRoot' projectOpts pVersion pExposedModules pDependencies - let eventLogger (EventFileDiagnostics fp diags) = printDiagnostics $ map (fp,) diags + let eventLogger (EventFileDiagnostics fp diags) = printDiagnostics $ map (toNormalizedFilePath fp,) diags eventLogger _ = return () Compiler.withIdeState opts loggerH eventLogger $ \compilerH -> do darOrErr <- runExceptT $ Compiler.buildDar compilerH - pMain + (toNormalizedFilePath pMain) pExposedModules pName pSdkVersion @@ -454,7 +454,7 @@ execPackage projectOpts filePath opts mbOutFile dumpPom dalfInput = withProjectR loggerH <- getLogger opts "package" filePath <- relativize filePath opts' <- Compiler.mkOptions opts - Compiler.withIdeState opts' loggerH (const $ pure ()) $ buildDar filePath + Compiler.withIdeState opts' loggerH (const $ pure ()) $ buildDar (toNormalizedFilePath filePath) where -- This is somewhat ugly but our CLI parser guarantees that this will always be present. -- We could parametrize CliOptions by whether the package name is optional diff --git a/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc/Command/Damldoc.hs b/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc/Command/Damldoc.hs index ee12a9bb35..333b5b063b 100644 --- a/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc/Command/Damldoc.hs +++ b/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc/Command/Damldoc.hs @@ -8,6 +8,7 @@ module DA.Cli.Damlc.Command.Damldoc(cmdDamlDoc, cmdRenderDoc) where import DA.Cli.Damlc.Base(Command) import DA.Cli.Options import DA.Daml.GHC.Damldoc.Driver +import Development.IDE.Types.Diagnostics import Options.Applicative import Data.Maybe @@ -123,7 +124,7 @@ data CmdArgs = Damldoc { cInputFormat :: InputFormat deriving (Eq, Show, Read) exec :: CmdArgs -> Command -exec Damldoc{..} = damlDocDriver cInputFormat cOutput cFormat cPrefix options cMainFiles +exec Damldoc{..} = damlDocDriver cInputFormat cOutput cFormat cPrefix options (map toNormalizedFilePath cMainFiles) where options = [ IncludeModules cIncludeMods | not $ null cIncludeMods] <> [ ExcludeModules cExcludeMods | not $ null cExcludeMods] <> diff --git a/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc/Test.hs b/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc/Test.hs index 981d00cb90..0c2007755b 100644 --- a/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc/Test.hs +++ b/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc/Test.hs @@ -38,11 +38,11 @@ import qualified Text.XML.Light as XML newtype UseColor = UseColor {getUseColor :: Bool} -- | Test a DAML file. -execTest :: [FilePath] -> UseColor -> Maybe FilePath -> Compiler.Options -> IO () +execTest :: [NormalizedFilePath] -> UseColor -> Maybe FilePath -> Compiler.Options -> IO () execTest inFiles color mbJUnitOutput cliOptions = do loggerH <- getLogger cliOptions "test" opts <- Compiler.mkOptions cliOptions - let eventLogger (EventFileDiagnostics fp diags) = printDiagnostics $ map (fp,) diags + let eventLogger (EventFileDiagnostics fp diags) = printDiagnostics $ map (toNormalizedFilePath fp,) diags eventLogger _ = return () Compiler.withIdeState opts loggerH eventLogger $ \h -> do let lfVersion = Compiler.optDamlLfVersion cliOptions @@ -51,7 +51,7 @@ execTest inFiles color mbJUnitOutput cliOptions = do when (any ((Just DsError ==) . _severity . snd) diags) exitFailure -testRun :: IdeState -> [FilePath] -> LF.Version -> UseColor -> Maybe FilePath -> IO () +testRun :: IdeState -> [NormalizedFilePath] -> LF.Version -> UseColor -> Maybe FilePath -> IO () testRun h inFiles lfVersion color mbJUnitOutput = do -- make sure none of the files disappear liftIO $ Compiler.setFilesOfInterest h inFiles @@ -79,7 +79,7 @@ testRun h inFiles lfVersion color mbJUnitOutput = do -- We didn't get scenario results, so we use the diagnostics as the error message for each scenario. -failedTestOutput :: IdeState -> FilePath -> CompilerService.Action [(VirtualResource, Maybe T.Text)] +failedTestOutput :: IdeState -> NormalizedFilePath -> CompilerService.Action [(VirtualResource, Maybe T.Text)] failedTestOutput h file = do mbScenarioNames <- CompilerService.getScenarioNames file diagnostics <- liftIO $ CompilerService.getDiagnostics h @@ -91,7 +91,7 @@ printScenarioResults :: [(VirtualResource, SS.ScenarioResult)] -> UseColor -> IO printScenarioResults results color = do liftIO $ forM_ results $ \(VRScenario vrFile vrName, result) -> do let doc = prettyResult result - let name = DA.Pretty.string vrFile <> ":" <> DA.Pretty.pretty vrName + let name = DA.Pretty.string (fromNormalizedFilePath vrFile) <> ":" <> DA.Pretty.pretty vrName let stringStyleToRender = if getUseColor color then DA.Pretty.renderColored else DA.Pretty.renderPlain putStrLn $ stringStyleToRender (name <> ": " <> doc) @@ -120,7 +120,7 @@ prettyResult result = <> DA.Pretty.int nTx <> DA.Pretty.typeDoc_ " transactions." -toJUnit :: [(FilePath, [(VirtualResource, Maybe T.Text)])] -> XML.Element +toJUnit :: [(NormalizedFilePath, [(VirtualResource, Maybe T.Text)])] -> XML.Element toJUnit results = XML.node (XML.unqual "testsuites") @@ -133,20 +133,20 @@ toJUnit results = where tests = length $ concatMap snd results failures = length $ concatMap (mapMaybe snd . snd) results - handleFile :: (FilePath, [(VirtualResource, Maybe T.Text)]) -> XML.Element + handleFile :: (NormalizedFilePath, [(VirtualResource, Maybe T.Text)]) -> XML.Element handleFile (f, vrs) = XML.node (XML.unqual "testsuite") - ([ XML.Attr (XML.unqual "name") f + ([ XML.Attr (XML.unqual "name") (fromNormalizedFilePath f) , XML.Attr (XML.unqual "tests") (show $ length vrs) ], map (handleVR f) vrs) - handleVR :: FilePath -> (VirtualResource, Maybe T.Text) -> XML.Element + handleVR :: NormalizedFilePath -> (VirtualResource, Maybe T.Text) -> XML.Element handleVR f (vr, mbErr) = XML.node (XML.unqual "testcase") ([ XML.Attr (XML.unqual "name") (T.unpack $ vrScenarioName vr) - , XML.Attr (XML.unqual "classname") f + , XML.Attr (XML.unqual "classname") (fromNormalizedFilePath f) ], maybe [] (\err -> [XML.node (XML.unqual "failure") (T.unpack err)]) mbErr ) diff --git a/daml-foundations/daml-tools/da-hs-daml-cli/tests/DamlcTest.hs b/daml-foundations/daml-tools/da-hs-daml-cli/tests/DamlcTest.hs index 5479914caa..b8b1b7e475 100644 --- a/daml-foundations/daml-tools/da-hs-daml-cli/tests/DamlcTest.hs +++ b/daml-foundations/daml-tools/da-hs-daml-cli/tests/DamlcTest.hs @@ -15,6 +15,7 @@ import Test.Tasty.HUnit import qualified DA.Cli.Damlc.Test as Damlc import DA.Daml.GHC.Compiler.Options +import Development.IDE.Types.Diagnostics main :: IO () main = do @@ -40,7 +41,7 @@ tests = testGroup , "module Foo where" , "abc" ] - shouldThrowExitFailure (Damlc.execTest [path] (Damlc.UseColor False) Nothing opts) + shouldThrowExitFailure (Damlc.execTest [toNormalizedFilePath path] (Damlc.UseColor False) Nothing opts) , testCase "File with failing scenario" $ do withTempFile $ \path -> do T.writeFileUtf8 path $ T.unlines @@ -48,7 +49,7 @@ tests = testGroup , "module Foo where" , "x = scenario $ assert False" ] - shouldThrowExitFailure (Damlc.execTest [path] (Damlc.UseColor False) Nothing opts) + shouldThrowExitFailure (Damlc.execTest [toNormalizedFilePath path] (Damlc.UseColor False) Nothing opts) ] shouldThrowExitFailure :: IO () -> IO ()