digital-asset/daml
1
1
Fork 0
mirror of https://github.com/digital-asset/daml.git synced 2024-09-20 17:28:46 +03:00
Code Issues Projects Releases Wiki Activity

Introduce a newtype for file paths with normalized slashes (#1633)

Browse Source 
This implements part 2 of #1507 and fixes the daml-ghc-test-dev test
suite on Windows (not enabled on CI due to GRPC issues).

I have also tested this in the IDE on Windows and Linux.
This commit is contained in:
Moritz Kiefer 2019-06-13 15:11:47 +02:00 committed by GitHub
parent 8faa414760
commit be63c39d0d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
34 changed files with 266 additions and 218 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/haskell-ide-core/src/Development/IDE/Functions/Compile.hs
View File

@ -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 =

42
compiler/haskell-ide-core/src/Development/IDE/Functions/DependencyInformation.hs
View File

@ -36,20 +36,20 @@ import Module
-- | Unprocessed results that we get from following all imports recursively starting from a module.
data RawDependencyInformation = RawDependencyInformation
{ moduleDependencies :: Map FilePath (Either ModuleParseError [(Located ModuleName, Maybe FilePath)])
, pkgDependencies :: Map FilePath (Set InstalledUnitId)
{ moduleDependencies :: Map NormalizedFilePath (Either ModuleParseError [(Located ModuleName, Maybe NormalizedFilePath)])
, pkgDependencies :: Map NormalizedFilePath (Set InstalledUnitId)
-- ^ Transitive dependencies on pkgs of this file, i.e. immidiate package dependencies and the
-- transitive package dependencies of those packages.
}
data DependencyInformation =
DependencyInformation
{ depErrorNodes :: Map FilePath (NonEmpty NodeError)
{ depErrorNodes :: Map NormalizedFilePath (NonEmpty NodeError)
-- ^ Nodes that cannot be processed correctly.
, depModuleDeps :: Map FilePath (Set FilePath)
, depModuleDeps :: Map NormalizedFilePath (Set NormalizedFilePath)
-- ^ For a non-error node, this contains the set of module immediate dependencies
-- in the same package.
, depPkgDeps :: Map FilePath (Set InstalledUnitId)
, depPkgDeps :: Map NormalizedFilePath (Set InstalledUnitId)
-- ^ For a non-error node, this contains the set of immediate pkg deps.
} deriving (Show, Generic)
@ -69,7 +69,7 @@ instance NFData LocateError
-- | An error attached to a node in the dependency graph.
data NodeError
= PartOfCycle (Located ModuleName) [FilePath]
= PartOfCycle (Located ModuleName) [NormalizedFilePath]
-- ^ This module is part of an import cycle. The module name corresponds
-- to the import that enters the cycle starting from this module.
-- The list of filepaths represents the elements
@ -94,10 +94,12 @@ instance NFData NodeError where
-- `ErrorNode`. Otherwise it is a `SuccessNode`.
data NodeResult
= ErrorNode (NonEmpty NodeError)
| SuccessNode [(Located ModuleName, FilePath)]
| SuccessNode [(Located ModuleName, NormalizedFilePath)]
deriving Show
partitionNodeResults :: [(a, NodeResult)] -> ([(a, NonEmpty NodeError)], [(a, [(Located ModuleName, FilePath)])])
partitionNodeResults
:: [(a, NodeResult)]
-> ([(a, NonEmpty NodeError)], [(a, [(Located ModuleName, NormalizedFilePath)])])
partitionNodeResults = partitionEithers . map f
where f (a, ErrorNode errs) = Left (a, errs)
f (a, SuccessNode imps) = Right (a, imps)
@ -116,7 +118,7 @@ processDependencyInformation rawResults =
, depPkgDeps = pkgDependencies rawResults
}
where resultGraph = buildResultGraph rawResults
successEdges :: [(FilePath, FilePath, [FilePath])]
successEdges :: [(NormalizedFilePath, NormalizedFilePath, [NormalizedFilePath])]
successEdges = map (\(k,ks) -> (k,k,ks)) $ MS.toList $
MS.map (map snd) $ MS.mapMaybe successNode resultGraph
moduleDeps =
@ -131,22 +133,22 @@ processDependencyInformation rawResults =
-- 2. Mark each node that has a parse error as an error node.
-- 3. Mark each node whose immediate children could not be located as an error.
-- 4. Recursively propagate errors to parents if they are not already error nodes.
buildResultGraph :: RawDependencyInformation -> Map FilePath NodeResult
buildResultGraph :: RawDependencyInformation -> Map NormalizedFilePath NodeResult
buildResultGraph g = propagatedErrors
where
sccs = stronglyConnComp (graphEdges g)
(_, cycles) = partitionSCC sccs
cycleErrors :: Map FilePath NodeResult
cycleErrors :: Map NormalizedFilePath NodeResult
cycleErrors = MS.unionsWith (<>) $ map errorsForCycle cycles
errorsForCycle :: [FilePath] -> Map FilePath NodeResult
errorsForCycle :: [NormalizedFilePath] -> Map NormalizedFilePath NodeResult
errorsForCycle files =
MS.fromListWith (<>) (concatMap (cycleErrorsForFile files) files)
cycleErrorsForFile :: [FilePath] -> FilePath -> [(FilePath,NodeResult)]
cycleErrorsForFile :: [NormalizedFilePath] -> NormalizedFilePath -> [(NormalizedFilePath,NodeResult)]
cycleErrorsForFile cycle f =
let entryPoints = mapMaybe (findImport f) cycle
in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints
otherErrors = MS.map otherErrorsForFile (moduleDependencies g)
otherErrorsForFile :: Either ModuleParseError [(Located ModuleName, Maybe FilePath)] -> NodeResult
otherErrorsForFile :: Either ModuleParseError [(Located ModuleName, Maybe NormalizedFilePath)] -> NodeResult
otherErrorsForFile (Left err) = ErrorNode (ParseError err :| [])
otherErrorsForFile (Right imports) =
let toEither (imp, Nothing) = Left imp
@ -171,17 +173,17 @@ buildResultGraph g = propagatedErrors
in case nonEmpty errs of
Nothing -> n
Just errs' -> ErrorNode (NonEmpty.map (ParentOfErrorNode . fst) errs')
findImport :: FilePath -> FilePath -> Maybe (Located ModuleName)
findImport :: NormalizedFilePath -> NormalizedFilePath -> Maybe (Located ModuleName)
findImport file importedFile =
case moduleDependencies g MS.! file of
Left _ -> error "Tried to call findImport on a module with a parse error"
Right imports ->
fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) imports
graphEdges :: RawDependencyInformation -> [(FilePath, FilePath, [FilePath])]
graphEdges :: RawDependencyInformation -> [(NormalizedFilePath, NormalizedFilePath, [NormalizedFilePath])]
graphEdges g =
map (\(k, ks) -> (k, k, ks)) $ MS.toList $ MS.map deps $ moduleDependencies g
where deps :: Either e [(i, Maybe FilePath)] -> [FilePath]
where deps :: Either e [(i, Maybe NormalizedFilePath)] -> [NormalizedFilePath]
deps (Left _) = []
deps (Right imports) = mapMaybe snd imports
@ -190,17 +192,17 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest
partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
partitionSCC [] = ([], [])
transitiveDeps :: DependencyInformation -> FilePath -> Maybe TransitiveDependencies
transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
transitiveDeps DependencyInformation{..} f = do
reachableVs <- Set.delete f . Set.fromList . map (fst3 . fromVertex) . reachable g <$> toVertex f
let transitiveModuleDeps = filter (\v -> v `Set.member` reachableVs) $ map (fst3 . fromVertex) vs
let transitivePkgDeps = Set.toList $ foldMap (\f -> MS.findWithDefault Set.empty f depPkgDeps) (f : transitiveModuleDeps)
pure $ TransitiveDependencies {..}
pure TransitiveDependencies {..}
where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, Set.toList fs)) $ MS.toList depModuleDeps)
vs = topSort g
data TransitiveDependencies = TransitiveDependencies
{ transitiveModuleDeps :: [FilePath]
{ transitiveModuleDeps :: [NormalizedFilePath]
-- ^ Transitive module dependencies in topological order.
-- The module itself is not included.
, transitivePkgDeps :: [InstalledUnitId]

11
compiler/haskell-ide-core/src/Development/IDE/Functions/FindImports.hs
View File

@ -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)

4
compiler/haskell-ide-core/src/Development/IDE/Functions/GHCError.hs
View File

@ -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).

13
compiler/haskell-ide-core/src/Development/IDE/Functions/SpanInfo.hs
View File

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

18
compiler/haskell-ide-core/src/Development/IDE/State/FileStore.hs
View File

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

37
compiler/haskell-ide-core/src/Development/IDE/State/Rules.hs
View File

@ -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)

5
compiler/haskell-ide-core/src/Development/IDE/State/Service.hs
View File

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

32
compiler/haskell-ide-core/src/Development/IDE/State/Shake.hs
View File

@ -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 =

62
compiler/haskell-ide-core/src/Development/IDE/Types/Diagnostics.hs
View File

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

6
compiler/haskell-ide-core/src/Development/IDE/Types/LSP.hs
View File

@ -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.

4
compiler/haskell-ide-core/test/Demo.hs
View File

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

21
daml-foundations/daml-ghc/daml-compiler/src/DA/Service/Daml/Compiler/Impl/Dar.hs
View File

@ -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 <name> 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)

27
daml-foundations/daml-ghc/daml-compiler/src/DA/Service/Daml/Compiler/Impl/Handle.hs
View File

@ -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 $

1
daml-foundations/daml-ghc/damldoc/BUILD.bazel
View File

@ -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",

6
daml-foundations/daml-ghc/damldoc/src/DA/Daml/GHC/Damldoc/Driver.hs
View File

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

4
daml-foundations/daml-ghc/damldoc/src/DA/Daml/GHC/Damldoc/HaddockParse.hs
View File

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

3
daml-foundations/daml-ghc/damldoc/test/DA/Daml/GHC/Damldoc/Tests.hs
View File

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

2
daml-foundations/daml-ghc/ghc-compiler/src/DA/Daml/GHC/Compiler/Convert.hs
View File

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

7
daml-foundations/daml-ghc/ide/src/Development/IDE/State/RuleTypes/Daml.hs
View File

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

44
daml-foundations/daml-ghc/ide/src/Development/IDE/State/Rules/Daml.hs
View File

@ -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 =

3
daml-foundations/daml-ghc/ide/src/Development/IDE/State/Service/Daml.hs
View File

@ -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.

45
daml-foundations/daml-ghc/ide/test/Development/IDE/State/API/Testing.hs
View File

@ -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 ()

12
daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs
View File

@ -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 }

4
daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/CodeLens.hs
View File

@ -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 []

4
daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Definition.hs
View File

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

4
daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/Hover.hs
View File

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

17
daml-foundations/daml-ghc/test-src/DA/Test/GHC.hs
View File

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

3
daml-foundations/daml-ghc/test-src/DA/Test/ShakeIdeClient.hs
View File

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

1
daml-foundations/daml-tools/da-hs-daml-cli/BUILD.bazel
View File

@ -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",
],

12
daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs
View File

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

3
daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc/Command/Damldoc.hs
View File

@ -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] <>

20
daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc/Test.hs
View File

@ -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
)

5
daml-foundations/daml-tools/da-hs-daml-cli/tests/DamlcTest.hs
View File

@ -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 ()