diff --git a/CoreLicenses.txt b/CoreLicenses.txt new file mode 100644 --- /dev/null +++ b/CoreLicenses.txt @@ -0,0 +1,80 @@ +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +----------------------------------------------------------------------------- + +Code derived from the document "Report on the Programming Language +Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + +----------------------------------------------------------------------------- + +Code derived from the document "The Haskell 98 Foreign Function +Interface, An Addendum to the Haskell 98 Report" is distributed under +the following license: + + Copyright (c) 2002 Manuel M. T. Chakravarty + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Foreign Function Interface. + +----------------------------------------------------------------------------- + +Copyright 1991, 1996, 1999, 2000 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as published by +the Free Software Foundation; either version 2.1 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public +License for more details. + +----------------------------------------------------------------------------- diff --git a/IdeSession.hs b/IdeSession.hs new file mode 100644 --- /dev/null +++ b/IdeSession.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, DeriveDataTypeable #-} +-- | This module provides an interface to the IDE backend. It centres around +-- the idea of a single threaded IDE session, and operations for updating the +-- session or running queries given the current state of the session. +-- +-- /Interaction with the compiler/ +-- +-- Ironically for a pure functional language, the interface to the compiler is +-- rather stateful and sequential. In part this is because it's dealing with +-- the state of files in the file system which are of course mutable variables. +-- +-- So the general pattern of interaction is sequential and single-threaded. +-- The state transitions are fairly simple: +-- +-- * update phase: we have a batch of updates, e.g. changes in module contents. +-- This part is declarative, we just describe what changes we want to make. +-- +-- * compile phase: we apply the updates and invoke the compiler, which +-- incrementally recompiles some modules. This may be a relatively long +-- running operation and we may want progress info. +-- +-- * query phase: after compiling we can collect information like source +-- errors, the list of successfully loaded modules or symbol maps. +-- +-- * run phase: regardless of compilation results, we may want to run some +-- code from a module (compiled recently or compiled many updates ago), +-- interact with the running code's input and output, interrupt its +-- execution. +-- +-- Then the whole process can repeat. +-- +-- To clarify these different phases we use different types: +-- +-- * 'IdeSession' for the query mode. This is in a sense also the default +-- mode. +-- +-- * 'IdeSessionUpdate' for accumulating updates. +-- +-- * 'Progress' for the progress information in the compile mode. +-- +-- * 'RunActions' for handles on the running code, through which +-- one can interact with the code. +-- +-- /Additional notes/ +-- +-- * Responsibility for managing and mutating files in the sources dir. +-- +-- In general, updating and changing source files in the sources dir has to be +-- coordinated with the IdeSession, since we're in a concurrent mutable +-- setting. +-- +-- The model here is that the IdeSession alone manages the files in the sources +-- directory. All file changes and file reading must be managed via the +-- session, and sequenced relative to other session state changes. +-- +-- The session will manage the files carefully, including in the case of +-- exceptions and things going awry. Thus the caller does not need to duplicate +-- the file state: it can rely on putting files in, applying updates to the +-- files via the session, and extracting the files again at any time (before +-- the session is closed). +-- +-- * Morally pure queries +-- +-- Morally, a compiler is a pure function from the current value of the various +-- source files (and other bits of the environment) to object code and\/or +-- other information about the modules (errors, types etc). +-- +-- The intention is to reflect this purity property in this interface. The +-- value of an 'IdeSession' represents the state of the files\/modules and +-- contains the other parameters supplied by the user (compiler options, +-- environment variables). It also contains or represents the result of the +-- pure compilation function. It should always be the case that we can throw +-- away all the compilation results and recover them just from the file state +-- and user parameters. +-- +-- One example where this notion makes a difference is with warnings. +-- Traditionally, compilers just return the warnings for the modules they +-- compiled, skipping warnings for the modules they didn't need to recompile. +-- But this doesn't match the pure function idea, because the compilation +-- result now depends on which steps we took to get there, rather than just on +-- the current value of the files. So one of the things this wrapper can do is +-- to restore the purity in these corner cases (which otherwise the client of +-- this API would probably have to do). +-- +-- * Persistent and transitory state +-- +-- The persistent state is obviously the files: source files and data files, as +-- well as user-supplied parameters of the compilation. Internally there is a +-- great deal of transitory and cached state, either in memory or on disk (such +-- as .hi files on disk or the equivalent in memory). Note that none of the +-- state persists in case of a fatal internal error (the files are wiped out +-- before shutdown) and only the files persist in case of a power failure (but +-- have to be recovered manually). +-- +-- It should be possible to drop all the transitory state and recover, just at +-- the cost of some extra work, as long as the original @Session@ value is +-- available. The 'restartSession' function does almost exactly that. +-- +-- This property is a useful correctness property for internal testing: the +-- results of all the queries should be the same before and after blowing away +-- all the transitory state and recovering. +module IdeSession ( + -- * Configuration + SessionConfig(..) + , defaultSessionConfig + , InProcess + -- * Updating the session + -- ** Starting and stopping + , IdeSession -- Abstract + , initSession + , SessionInitParams(..) + , defaultSessionInitParams + , shutdownSession + , forceShutdownSession + , restartSession + -- ** Session updates + , IdeSessionUpdate -- Abstract + , updateSession + , updateSourceFile + , updateSourceFileFromFile + , updateSourceFileDelete + , updateGhcOpts + , updateRtsOpts + , updateRelativeIncludes + , updateCodeGeneration + , updateDataFile + , updateDataFileFromFile + , updateDataFileDelete + , updateDeleteManagedFiles + , updateEnv + , updateArgs + , updateStdoutBufferMode + , updateStderrBufferMode + , updateTargets + , buildExe + , buildDoc + , buildLicenses + -- ** Progress + , Progress(..) + -- ** Running code + , RunActions(..) + , RunResult(..) + , RunBufferMode(..) + , BreakInfo(..) + , runStmt + , runExe + , resume + , runWaitAll + , setBreakpoint + , printVar + -- * Queries + -- ** Types + , Query + , ManagedFiles(..) + , Targets(..) + , GhcVersion(..) + -- ** Queries that rely on the static part of the state only + , getSessionConfig + , getSourcesDir + , getDataDir + , getDistDir + , getSourceModule + , getDataFile + , getAllDataFiles + , getCabalMacros + -- ** Queries that do not rely on computed state + , getCodeGeneration + , getEnv + , getGhcServer + , getGhcVersion + , getManagedFiles + , getBreakInfo + -- ** Queries that rely on computed state + , getSourceErrors + , getLoadedModules + , getFileMap + , getBuildExeStatus + , getBuildDocStatus + , getBuildLicensesStatus + , getSpanInfo + , getExpTypes + , getUseSites + , getDotCabal + , getImports + , getAutocompletion + , getPkgDeps + -- * Types for identifier info, errors, etc. + -- ** Types + , IdNameSpace(..) + , Type + , IdInfo(..) + , IdProp(..) + , IdScope(..) + , SourceSpan(..) + , EitherSpan(..) + , SourceError(..) + , SourceErrorKind(..) + , ModuleName + , ModuleId(..) + , PackageId(..) +-- , IdMap(..) +-- , LoadedModules + , ImportEntities(..) + , Import(..) + , SpanInfo(..) + -- ** Util + , idInfoQN +--, idInfoAtLocation + , haddockLink + -- * Exception types + , ExternalException(..) + , InvalidSessionStateQueries(..) + -- * Re-exports from Cabal + , PackageDBStack + , PackageDB(..) + -- * For internal/debugging use only + , getGhcExitCode + , dumpIdInfo + , dumpAutocompletion + , dumpFileMap + , crashGhcServer + , sourceExtensions + , ideBackendApiVersion + , buildLicsFromPkgs + , LicenseArgs(..) +) where + +import Distribution.Simple (PackageDBStack, PackageDB(..)) + +import IdeSession.Config +import IdeSession.GHC.API +import IdeSession.GHC.Client +import IdeSession.Query +import IdeSession.RPC.Client (ExternalException (..)) +import IdeSession.State (IdeSession) +import IdeSession.Types.Progress +import IdeSession.Types.Public +import IdeSession.Update diff --git a/IdeSession/Cabal.hs b/IdeSession/Cabal.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Cabal.hs @@ -0,0 +1,947 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module IdeSession.Cabal ( + buildDeps, externalDeps + , configureAndBuild, configureAndHaddock + , generateMacros, buildDotCabal + , runComponentCc + , BuildExeArgs(..), RunCcArgs(..), LicenseArgs(..) + , ExeCabalRequest(..), ExeCabalResponse(..) + , buildLicsFromPkgs + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad +import Data.Binary +import Data.Function (on) +import Data.List hiding (find) +import Data.Maybe (catMaybes, fromMaybe, isNothing) +import Data.Monoid (Monoid(..)) +import Data.Time +import Data.Typeable (Typeable) +import Data.Version (Version (..), parseVersion) +import System.Directory (removeFile, doesFileExist) +import System.Exit (ExitCode (ExitSuccess, ExitFailure), exitFailure) +import System.FilePath +import System.FilePath.Find (find, always, extension) +import System.IO +import System.IO.Error (isUserError, catchIOError) +import System.IO.Temp (createTempDirectory) +import Text.ParserCombinators.ReadP (readP_to_S) +import qualified Control.Exception as Ex +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL8 +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Language.Haskell.Extension as Haskell +import qualified Language.Haskell.TH.Syntax as TH + +import Distribution.License (License (..)) +import Distribution.PackageDescription +import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) +import Distribution.ParseUtils +import Distribution.Simple (PackageDBStack) +import Distribution.Simple.Build.Macros +import Distribution.Simple.Configure (configure) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) +import Distribution.Simple.PackageIndex ( lookupSourcePackageId ) +import Distribution.Simple.PreProcess (PPSuffixHandler) +import Distribution.Simple.Program.Builtin (ghcPkgProgram) +import Distribution.Simple.Program.Db (configureAllKnownPrograms, requireProgram) +import Distribution.Simple.Utils (createDirectoryIfMissingVerbose) +import Distribution.System (buildPlatform) +import Distribution.Verbosity (silent) +import Distribution.Version (anyVersion, thisVersion) +import qualified Distribution.Compiler as Compiler +import qualified Distribution.InstalledPackageInfo as InstInfo +import qualified Distribution.ModuleName +import qualified Distribution.Package as Package +import qualified Distribution.Simple.Build as Build +import qualified Distribution.Simple.Compiler as Simple.Compiler +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.Haddock as Haddock +import qualified Distribution.Simple.LocalBuildInfo as BuildInfo +import qualified Distribution.Simple.Program as Cabal.Program +import qualified Distribution.Simple.Program.GHC as GHC +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.Setup as Setup +import qualified Distribution.Text +import qualified Distribution.Utils.NubList as NubList + +import IdeSession.GHC.API (cExtensions, cHeaderExtensions) +import IdeSession.Licenses ( bsd3, gplv2, gplv3, lgpl2, lgpl3, apache20 ) +import IdeSession.State +import IdeSession.Strict.Container +import IdeSession.Strict.Maybe (just) +import IdeSession.Types.Progress +import IdeSession.Types.Public +import IdeSession.Types.Translation +import IdeSession.Util +import qualified IdeSession.Strict.List as StrictList +import qualified IdeSession.Strict.Map as StrictMap + +-- TODO: factor out common parts of exe building and haddock generation +-- after Cabal and the code that calls it are improved not to require +-- the configure step, etc. + +pkgNameMain :: Package.PackageName +pkgNameMain = Package.PackageName "main" -- matches the import default + +pkgVersionMain :: Version +pkgVersionMain = Version [1, 0] [] + +pkgDescFromName :: String -> Version -> PackageDescription +pkgDescFromName pkgName version = PackageDescription + { -- the following are required by all packages: + package = Package.PackageIdentifier + { pkgName = Package.PackageName pkgName + , pkgVersion = version + } + , license = AllRightsReserved -- dummy + , licenseFiles = [] + , copyright = "" + , maintainer = "" + , author = "" + , stability = "" + , testedWith = [] + , homepage = "" + , pkgUrl = "" + , bugReports = "" + , sourceRepos = [] + , synopsis = "" + , description = "" + , category = "" + , customFieldsPD = [] + , buildDepends = [] -- probably ignored + , specVersionRaw = Left $ Version [1, 14, 0] [] + , buildType = Just Simple + -- components + , library = Nothing -- ignored inside @GenericPackageDescription@ + , executables = [] -- ignored when inside @GenericPackageDescription@ + , testSuites = [] + , benchmarks = [] + , dataFiles = [] -- for now, we don't mention files from managedData? + , dataDir = "" -- for now we don't put ideDataDir? + , extraSrcFiles = [] + , extraTmpFiles = [] + , extraDocFiles = [] + } + +pkgDesc :: PackageDescription +pkgDesc = pkgDescFromName "main" pkgVersionMain + +bInfo :: [FilePath] -> [String] -> [FilePath] -> [FilePath] -> BuildInfo +bInfo hsSourceDirs ghcOpts cSources installIncludes = + emptyBuildInfo + { buildable = True + , defaultLanguage = Just Haskell.Haskell2010 + , options = [(Simple.Compiler.GHC, realGhcOptions)] + , ccOptions = actuallyCcOptions + , otherExtensions = [Haskell.EnableExtension Haskell.TemplateHaskell] -- TODO: specify in SessionConfig? + , hsSourceDirs + , cSources + , installIncludes + } + where + -- Cabal does not pass ghc-options to ghc when compiling C code, so we + -- must split these options out and explicitly pass them as options for the + -- C compiler. + -- + -- See https://github.com/fpco/ide-backend/issues/218 and + -- https://github.com/haskell/cabal/pull/2043 + actuallyCcOptions, realGhcOptions :: [String] + (actuallyCcOptions, realGhcOptions) = + let (cOpts, hsOpts) = partition isCcOpt ghcOpts + in (map (drop 5) cOpts, hsOpts) + + isCcOpt :: String -> Bool + isCcOpt = isPrefixOf "-optc" + +-- @relative@ is a hack, because when building, we need an absolute path +-- (so that ghc sees the .c files), but .cabal files need a relative path +-- (and that's enough for 'cabal install', since the package dir +-- will have both the .cabal and the C sources, unlike the directories +-- we build exes in). +getCSources :: Bool -> [FilePath] -> IO [FilePath] +getCSources relative [sourceDir] = do + files <- find always ((`elem` cExtensions) `liftM` extension) sourceDir + return $ if relative + then map (makeRelative sourceDir) files + else files +getCSources _ _sourceDirs = + fail $ "getCSources: wrong sourceDir: " ++ intercalate ", " _sourceDirs + +getCHeaders :: [FilePath] -> IO [FilePath] +getCHeaders [sourceDir] = + fmap (map takeFileName) $ + find always ((`elem` cHeaderExtensions) `liftM` extension) sourceDir +getCHeaders _sourceDirs = + fail $ "getCHeaders: wrong sourceDir: " ++ intercalate ", " _sourceDirs + +-- TODO: this works OK if @(m, path)@ are simple, @updateRelativeIncludes@ +-- includes @""@ and/or the @Main@ module is in @Main.hs@. +-- For more complex cases we'd need extensive exotic tests and then perhaps +-- also more complex code that searches @updateRelativeIncludes@ paths, etc. +-- I'd rather wait until we fix cabal/GHC not to require "Main" in "./Main.hs" +-- and then simplify this and other code instead. +exeDesc :: [FilePath] -> [FilePath] -> FilePath -> [String] + -> (ModuleName, FilePath) + -> IO Executable +exeDesc ideSourcesDir ideSourcesDirForC ideDistDir ghcOpts (m, path) = do + cSources <- getCSources False ideSourcesDirForC + cHeaders <- getCHeaders ideSourcesDirForC + let exeName = Text.unpack m + if exeName == "Main" then do -- that's what Cabal expects, no wrapper needed + return $ Executable + { exeName + , modulePath = path + , buildInfo = bInfo ideSourcesDir ghcOpts cSources cHeaders + } + else do + -- TODO: Verify @path@ somehow. + mDir <- createTempDirectory ideDistDir exeName + -- Cabal insists on "Main" and on ".hs". + let modulePath = mDir "Main.hs" + wrapper = "import qualified " ++ exeName ++ "\n" + ++ "main = " ++ exeName ++ ".main" + writeFile modulePath wrapper + return $ Executable + { exeName + , modulePath + , buildInfo = bInfo [mDir] ghcOpts cSources cHeaders + } + +libDesc :: Bool -> [FilePath] -> [FilePath] -> [String] + -> [Distribution.ModuleName.ModuleName] + -> IO Library +libDesc relative ideSourcesDir ideSourcesDirForC ghcOpts ms = do + cSources <- getCSources relative ideSourcesDirForC + cHeaders <- getCHeaders ideSourcesDirForC + return $ Library + { exposedModules = ms + , libExposed = False + , libBuildInfo = bInfo ideSourcesDir ghcOpts cSources cHeaders + -- These are new fields. TODO: Do we give them the right values? + , reexportedModules = [] + , requiredSignatures = [] + , exposedSignatures = [] + } + +-- TODO: we could do the parsing early and export parsed Versions via our API, +-- but we'd need to define our own strict internal variant of Version, etc. +parseVersionString :: Monad m => String -> m Version +parseVersionString versionString = do + let parser = readP_to_S parseVersion + case [ v | (v, "") <- parser versionString] of + [v] -> return v + _ -> fail $ "parseVersionString: can't parse package version: " + ++ versionString + +externalDeps :: Monad m => [PackageId] -> m [Package.Dependency] +externalDeps pkgs = + let depOfName :: Monad m => PackageId -> m (Maybe Package.Dependency) + depOfName PackageId{packageName, packageVersion = Nothing} = do + let packageN = Package.PackageName $ Text.unpack $ packageName + if packageN == pkgNameMain then return Nothing + else return $ Just $ Package.Dependency packageN anyVersion + depOfName PackageId{packageName, packageVersion = Just versionText} = do + let packageN = Package.PackageName $ Text.unpack $ packageName + versionString = Text.unpack versionText + version <- parseVersionString versionString + return $ Just $ Package.Dependency packageN (thisVersion version) + in liftM catMaybes $ mapM depOfName pkgs + +mkConfFlags :: FilePath -> PackageDBStack -> [FilePath] -> Setup.ConfigFlags +mkConfFlags ideDistDir configPackageDBStack progPathExtra = + (Setup.defaultConfigFlags (defaultProgramConfiguration progPathExtra)) + { Setup.configDistPref = Setup.Flag ideDistDir + , Setup.configUserInstall = Setup.Flag False + , Setup.configVerbosity = Setup.Flag minBound + -- @Nothing@ wipes out default, initial DBs. + , Setup.configPackageDBs = Nothing : map Just configPackageDBStack + , Setup.configProgramPathExtra = NubList.toNubList progPathExtra + } + +configureAndBuild :: BuildExeArgs + -> [(ModuleName, FilePath)] + -> IO ExitCode +configureAndBuild BuildExeArgs{ bePackageDBStack = configPackageDBStack + , beExtraPathDirs = configExtraPathDirs + , beSourcesDir = ideSourcesDir + , beDistDir = ideDistDir + , beRelativeIncludes = relativeIncludes + , beGhcOpts = ghcOpts + , beLibDeps = libDeps + , beLoadedMs = loadedMs + , .. } ms = do + -- We need to make sure the user never loses any error message. + -- Therefore we never wipe out such files in the midst of ide-backend + -- operation, but only at the start of user-triggered commands, + -- after he had full access to the previous content of the files. + beStderrLogExists <- doesFileExist beStderrLog + when beStderrLogExists $ removeFile beStderrLog + let mainDep = Package.Dependency pkgNameMain anyVersion + exeDeps = mainDep : libDeps + sourcesDirs = map (\path -> ideSourcesDir path) + relativeIncludes + executables <- + mapM (exeDesc sourcesDirs [ideSourcesDir] ideDistDir ghcOpts) ms + let condExe exe = (exeName exe, CondNode exe exeDeps []) + condExecutables = map condExe executables + mainFileExistsInDir dir = do + hsFound <- doesFileExist $ dir "Main.hs" + lhsFound <- doesFileExist $ dir "Main.lhs" + return $! hsFound || lhsFound + mainFileChecks <- mapM mainFileExistsInDir sourcesDirs + let mainFileExists = or mainFileChecks + -- Cabal can't find the code of @Main@ (to be used as the main executable + -- module) in subdirectories or in @Foo.hs@. We need a @Main@ to build + -- an executable, so any other @Main@ modules have to be ignored. + -- So, if another module depends on such a @Main@, + -- we're in trouble, but if the @Main@ is only an executable, we are fine. + -- Michael said in https://github.com/fpco/fpco/issues/1049 + -- "We'll be handling the disambiguation of Main modules ourselves before + -- passing the files to you, so that shouldn't be an ide-backend concern.", + -- so perhaps there won't be any problems. + let soundMs | mainFileExists = loadedMs + | otherwise = delete (Text.pack "Main") loadedMs + projectMs = map (Distribution.ModuleName.fromString . Text.unpack) soundMs + library <- libDesc False sourcesDirs [ideSourcesDir] ghcOpts projectMs + let gpDesc = GenericPackageDescription + { packageDescription = pkgDesc + , genPackageFlags = [] -- seem unused + , condLibrary = Just $ CondNode library libDeps [] + , condExecutables + , condTestSuites = [] + , condBenchmarks = [] + } + confFlags = mkConfFlags ideDistDir configPackageDBStack configExtraPathDirs + -- We don't override most build flags, but use configured values. + buildFlags = Setup.defaultBuildFlags + { Setup.buildDistPref = Setup.Flag ideDistDir + , Setup.buildVerbosity = Setup.Flag $ toEnum 1 + } + preprocessors :: [PPSuffixHandler] + preprocessors = [] + hookedBuildInfo = (Nothing, []) -- we don't want to use hooks + let confAndBuild = do + lbi <- configure (gpDesc, hookedBuildInfo) confFlags + -- Setting @withPackageDB@ here is too late, @configure@ would fail + -- already. Hence we set it in @mkConfFlags@ (can be reverted, + -- when/if we construct @lbi@ without @configure@). + Build.build (BuildInfo.localPkgDescr lbi) lbi buildFlags preprocessors + -- Handle various exceptions and stderr printouts. + exitCode :: Either ExitCode () <- redirectStderr beStderrLog $ + Ex.try $ catchIOError confAndBuild $ \e -> + if isUserError e + then do + -- In the new cabal code some exceptions are handled with 'die', + -- raising a user error, while some still do 'exit 1' and print to + -- stderr. For uniformity, we redirect user errors to stderr, as + -- well. + hPutStrLn stderr $ "Exception caught:" + hPutStrLn stderr $ show e + exitFailure + else + ioError e + return $! either id (const ExitSuccess) exitCode + +configureAndHaddock :: BuildExeArgs + -> IO ExitCode +configureAndHaddock BuildExeArgs{ bePackageDBStack = configPackageDBStack + , beExtraPathDirs = configExtraPathDirs + , beSourcesDir = ideSourcesDir + , beDistDir = ideDistDir + , beRelativeIncludes = relativeIncludes + , beGhcOpts = ghcOpts + , beLibDeps = libDeps + , beLoadedMs = loadedMs + , .. } = do + beStderrLogExists <- doesFileExist beStderrLog + when beStderrLogExists $ removeFile beStderrLog + let condExecutables = [] + sourcesDirs = map (\path -> ideSourcesDir path) + relativeIncludes + mainFileExistsInDir dir = do + hsFound <- doesFileExist $ dir "Main.hs" + lhsFound <- doesFileExist $ dir "Main.lhs" + return $! hsFound || lhsFound + mainFileChecks <- mapM mainFileExistsInDir sourcesDirs + let mainFileExists = or mainFileChecks + -- Cabal can't find the code of @Main@, except in the main dir. + -- See the comment above. + let soundMs | mainFileExists = loadedMs + | otherwise = delete (Text.pack "Main") loadedMs + projectMs = map (Distribution.ModuleName.fromString . Text.unpack) soundMs + library <- libDesc False sourcesDirs [ideSourcesDir] ghcOpts projectMs + let gpDesc = GenericPackageDescription + { packageDescription = pkgDesc + , genPackageFlags = [] -- seem unused + , condLibrary = Just $ CondNode library libDeps [] + , condExecutables + , condTestSuites = [] + , condBenchmarks = [] + } + confFlags = + mkConfFlags ideDistDir configPackageDBStack configExtraPathDirs + preprocessors :: [PPSuffixHandler] + preprocessors = [] + haddockFlags = Setup.defaultHaddockFlags + { Setup.haddockDistPref = Setup.Flag ideDistDir + , Setup.haddockHtml = Setup.Flag True + , Setup.haddockHoogle = Setup.Flag True + , Setup.haddockVerbosity = Setup.Flag minBound + } + hookedBuildInfo = (Nothing, []) -- we don't want to use hooks + let confAndBuild = do + lbi <- configure (gpDesc, hookedBuildInfo) confFlags + Haddock.haddock (BuildInfo.localPkgDescr lbi) lbi preprocessors haddockFlags + -- Handle various exceptions and stderr printouts. + exitCode :: Either ExitCode () <- redirectStderr beStderrLog $ + Ex.try $ catchIOError confAndBuild $ \e -> + if isUserError e + then do + -- In the new cabal code some exceptions are handled with 'die', + -- raising a user error, while some still do 'exit 1' and print to + -- stderr. For uniformity, we redirect user errors to stderr, as + -- well. + hPutStrLn stderr $ "Exception caught:" + hPutStrLn stderr $ show e + exitFailure + else + ioError e + return $! either id (const ExitSuccess) exitCode + +buildDotCabal :: FilePath -> [FilePath] -> [String] -> Computed + -> IO (String -> Version -> BSL.ByteString) +buildDotCabal ideSourcesDir relativeIncludes ghcOpts computed = do + (loadedMs, pkgs) <- buildDeps $ just computed + libDeps <- externalDeps pkgs + -- We ignore any @Main@ modules (even in subdirectories or in @Foo.hs@) + -- so that they don't get in the way when we build an executable + -- using the library. So, if another module depends on such a @Main@, + -- we're in trouble, but if the @Main@ is only an executable, we are fine. + -- Michael said in https://github.com/fpco/fpco/issues/1049 + -- "We'll be handling the disambiguation of Main modules ourselves before + -- passing the files to you, so that shouldn't be an ide-backend concern.", + -- so perhaps there won't be any problems. + let soundMs = delete (Text.pack "Main") loadedMs + projectMs = + sort $ map (Distribution.ModuleName.fromString . Text.unpack) soundMs + library <- libDesc True -- relative C files paths + (filter (/= "") relativeIncludes) [ideSourcesDir] + ghcOpts projectMs + let libE = library {libExposed = True} + gpDesc libName version = GenericPackageDescription + { packageDescription = pkgDescFromName libName version + , genPackageFlags = [] -- seem unused + , condLibrary = Just $ CondNode libE libDeps [] + , condExecutables = [] + , condTestSuites = [] + , condBenchmarks = [] + } + return $ \libName version -> + BSL8.pack $ showGenericPackageDescription $ gpDesc libName version + +lFieldDescrs :: [FieldDescr (Maybe License, Maybe FilePath, Maybe String)] +lFieldDescrs = + [ simpleField "license" + Distribution.Text.disp parseLicenseQ + (\(t1, _, _) -> fromMaybe BSD3 t1) (\l (_, t2, t3) -> (Just l, t2, t3)) + , simpleField "license-file" + showFilePath parseFilePathQ + (\(_, t2, _) -> fromMaybe "" t2) (\lf (t1, _, t3) -> (t1, Just lf, t3)) + , simpleField "author" + showFreeText parseFreeText + (\(_, _, t3) -> fromMaybe "???" t3) (\a (t1, t2, _) -> (t1, t2, Just a)) + ] + +-- | Build the concatenation of all license files from a given list +-- of packages. See 'buildLicenses'. +buildLicsFromPkgs :: Bool -> LicenseArgs + -> IO ExitCode +buildLicsFromPkgs logProgress + LicenseArgs{ liPackageDBStack = configPackageDBStack + , liExtraPathDirs = configExtraPathDirs + , liLicenseExc = configLicenseExc + , liDistDir = ideDistDir + , liStdoutLog = stdoutLogFN + , liStderrLog = stderrLogFN + , licenseFixed + , liCabalsDir = cabalsDir + , liPkgs = pkgs + } = do + -- Note that @liStderrLog@ is removed in @openBinaryFile@ below. + -- The following computations are very expensive, so should be done once, + -- instead of at each invocation of @findLicense@ that needs to perform + -- @lookupSourcePackageId@. + programDB <- configureAllKnownPrograms -- won't die + minBound (defaultProgramConfiguration configExtraPathDirs) + pkgIndex <- GHC.getInstalledPackages minBound configPackageDBStack programDB + let licensesFN = ideDistDir "licenses.txt" -- result + stderrLog <- openBinaryFile stderrLogFN WriteMode + licensesFile <- openBinaryFile licensesFN WriteMode + -- The file containing concatenated licenses for core components. + let bsCore = BSL8.pack $(TH.runIO (BSL.readFile "CoreLicenses.txt") >>= TH.lift . BSL8.unpack) + BSL.hPut licensesFile bsCore + + let numSteps = length pkgs + mainPackageName = Text.pack "main" + printProgress step packageName = + when logProgress $ + putStrLn $ "[" ++ show step ++ " of " ++ show numSteps + ++ "] " ++ Text.unpack packageName + + f :: (PackageId, Int) -> IO () + f (PackageId{packageName}, step) | packageName == mainPackageName = + printProgress step packageName + f (PackageId{..}, step) = do + let nameString = Text.unpack packageName + packageFile = cabalsDir nameString ++ ".cabal" + versionString = maybe "" Text.unpack packageVersion + version <- parseVersionString versionString + let _outputWarns :: [PWarning] -> IO () + _outputWarns [] = return () + _outputWarns warns = do + let warnMsg = "Parse warnings for " ++ packageFile ++ ":\n" + ++ unlines (map (showPWarning packageFile) warns) + hPutStrLn stderrLog warnMsg + cabalFileExists <- doesFileExist packageFile + if cabalFileExists then do + hPutStrLn licensesFile $ "\nLicense for " ++ nameString ++ ":\n" + pkgS <- readFile packageFile + let parseResult = + parseFields lFieldDescrs (Nothing, Nothing, Nothing) pkgS + findLicense parseResult nameString version packageFile + else case lookup nameString licenseFixed of + Just fixedLicense -> do + hPutStrLn licensesFile $ "\nLicense for " ++ nameString ++ ":\n" + let fakeParseResult = ParseOk undefined fixedLicense + findLicense fakeParseResult nameString version packageFile + Nothing -> + unless (nameString `elem` configLicenseExc) $ do + let errorMsg = "No .cabal file provided for package " + ++ nameString ++ " so no license can be found." + hPutStrLn licensesFile errorMsg + hPutStrLn stderrLog errorMsg + printProgress step packageName + + findLicense :: ParseResult (Maybe License, Maybe FilePath, Maybe String) + -> String -> Version -> FilePath + -> IO () + findLicense parseResult nameString version packageFile = + -- We can't use @parsePackageDescription@, because it defaults to + -- AllRightsReserved and we default to BSD3. It's very hard + -- to use the machinery from the inside of @parsePackageDescription@, + -- so instead we use the much simpler @ParseUtils.parseFields@. + -- The downside is that we are much less past- and future-proof + -- against .cabal format changes. The upside is @parseFields@ + -- is faster and does not care about most parsing errors + -- the .cabal file may (appear to) have. + case parseResult of + ParseFailed err -> do + hPutStrLn licensesFile $ snd $ locatedErrorMsg err + hPutStrLn stderrLog $ snd $ locatedErrorMsg err + ParseOk _warns (_, Just lf, _) -> do + -- outputWarns warns -- false positives + let pkgId = Package.PackageIdentifier + { pkgName = Package.PackageName nameString + , pkgVersion = version } + pkgInfos = lookupSourcePackageId pkgIndex pkgId + case pkgInfos of + InstInfo.InstalledPackageInfo{InstInfo.haddockInterfaces = hIn : _} : _ -> do + -- Since the license file path can't be specified + -- in InstalledPackageInfo, we can only guess what it is + -- and we do that on the basis of the haddock interfaces path. + -- TODO: on next rewrite (and re-testing), base it on htmldir + let candidatePaths = + [ iterate takeDirectory hIn !! 2 + -- covers cabal default case: htmldir = docdir/html + , takeDirectory hIn + -- covers case where htmldir = docdir, for in-place + , iterate takeDirectory hIn !! 5 + -- covers another case for in-place packages + ] + tryPaths (p : ps) = do + -- The directory of the license file is ignored + -- in installed packages, hence @takeFileName@. + let loc = p takeFileName lf + exists <- doesFileExist loc + if exists then do + bs <- BSL.readFile loc + BSL.hPut licensesFile bs + else tryPaths ps + tryPaths [] = do + let errorMsg = + "Package " ++ nameString + ++ " has no license file in path " + ++ concat (intersperse " nor " candidatePaths) + ++ ". Haddock interfaces path (from, e.g., --haddockdir or --docdir) is " + ++ hIn ++ "." + hPutStrLn licensesFile errorMsg + hPutStrLn stderrLog errorMsg + tryPaths candidatePaths + _ -> do + let errorMsg = "Package " ++ nameString + ++ " not properly installed." + ++ "\n" ++ show pkgInfos + hPutStrLn licensesFile errorMsg + hPutStrLn stderrLog errorMsg + ParseOk _warns (l, Nothing, mauthor) -> do + -- outputWarns warns -- false positives + when (isNothing l) $ do + let warnMsg = + "WARNING: Package " ++ packageFile + ++ " has no license nor license file specified." + hPutStrLn stderrLog warnMsg + let license = fromMaybe BSD3 l + author = fromMaybe "???" mauthor + ms <- licenseText license author + case ms of + Nothing -> do + let errorMsg = "No license text can be found for package " + ++ nameString ++ "." + hPutStrLn licensesFile errorMsg + hPutStrLn stderrLog errorMsg + Just s -> do + hPutStr licensesFile s + let assumed = if isNothing l + then " and the assumed" + else ", but" + warnMsg = + "WARNING: No license file specified for package " + ++ packageFile + ++ assumed + ++ " license is " + ++ show license + ++ ". Reproducing standard license text." + hPutStrLn stderrLog warnMsg + + res <- Ex.try $ mapM_ f (zip pkgs [1..]) + hClose stderrLog + hClose licensesFile + let handler :: Ex.IOException -> IO ExitCode + handler e = do + let msg = "Licenses concatenation failed. The exception is:\n" + ++ show e + writeFile stderrLogFN msg + return $ ExitFailure 1 + either handler (const $ return ExitSuccess) res + +-- Gives a list of all modules and a list of all transitive package +-- dependencies of the currently loaded project. +buildDeps :: Strict Maybe Computed -> IO ([ModuleName], [PackageId]) +buildDeps mcomputed = do + case toLazyMaybe mcomputed of + Nothing -> fail "This session state does not admit artifact generation." + Just Computed{..} -> do + let loadedMs = toLazyList computedLoadedModules + imp m = do + let mdeps = + fmap (toLazyList . StrictList.map (removeExplicitSharing + computedCache)) $ + StrictMap.lookup m computedPkgDeps + missing = fail $ "Module '" ++ Text.unpack m ++ "' not loaded." + return $ fromMaybe missing mdeps + imps <- mapM imp loadedMs + return $ (nub $ sort $ loadedMs, nub $ sort $ concat imps) + +licenseText :: License -> String -> IO (Maybe String) +licenseText license author = do + year <- getYear + return $! case license of + BSD3 -> Just $ bsd3 author (show year) + + (GPL (Just (Version {versionBranch = [2]}))) + -> Just gplv2 + + (GPL (Just (Version {versionBranch = [3]}))) + -> Just gplv3 + + (LGPL (Just (Version {versionBranch = [2]}))) + -> Just lgpl2 + + (LGPL (Just (Version {versionBranch = [3]}))) + -> Just lgpl3 + + (Apache (Just (Version {versionBranch = [2, 0]}))) + -> Just apache20 + + _ -> Nothing + +getYear :: IO Integer +getYear = do + u <- getCurrentTime + z <- getCurrentTimeZone + let l = utcToLocalTime z u + (y, _, _) = toGregorian $ localDay l + return y + +generateMacros :: PackageDBStack -> [FilePath] -> IO String +generateMacros configPackageDBStack configExtraPathDirs = do + let verbosity = silent + (_ghcPkg, ghcConf) <- requireProgram verbosity ghcPkgProgram + (defaultProgramConfiguration configExtraPathDirs) + let hcPkgInfo = GHC.hcPkgInfo ghcConf + pkgidss <- mapM (HcPkg.list hcPkgInfo verbosity) configPackageDBStack + let newestPkgs = map last . groupBy ((==) `on` Package.packageName) . sort . concat $ pkgidss + return $ generatePackageVersionMacros newestPkgs + +defaultProgramConfiguration :: [FilePath] -> Cabal.Program.ProgramConfiguration +defaultProgramConfiguration configExtraPathDirs = + Cabal.Program.setProgramSearchPath + ( Cabal.Program.ProgramSearchPathDefault + : map Cabal.Program.ProgramSearchPathDir configExtraPathDirs ) + Cabal.Program.defaultProgramConfiguration + +localBuildInfo :: FilePath -> PackageDBStack -> [FilePath] -> LocalBuildInfo +localBuildInfo buildDir withPackageDB configExtraPathDirs = BuildInfo.LocalBuildInfo + { BuildInfo.withPackageDB + , BuildInfo.withOptimization = Simple.Compiler.NormalOptimisation + , BuildInfo.hostPlatform = buildPlatform + , BuildInfo.withPrograms = defaultProgramConfiguration configExtraPathDirs + , BuildInfo.withProfLib = False + , BuildInfo.withSharedLib = False + , BuildInfo.compiler = Simple.Compiler.Compiler + -- TODO: Why is it okay that we always say 7.4.2 here? + { compilerId = Compiler.CompilerId Compiler.GHC (Version [7, 4, 2] []) + , compilerLanguages = error "compilerLanguages not defined" + , compilerExtensions = error "compilerExtensions not defined" + -- TOOD: new fields + , compilerAbiTag = error "compilerAbiTag not defined" + , compilerCompat = error "compilerCompat not defined" + , compilerProperties = Map.empty -- Must be defined + } + , BuildInfo.buildDir + , BuildInfo.configFlags = error "BuildInfo.configFlags not defined" + , BuildInfo.extraConfigArgs = error "BuildInfo.extraConfigArgs not defined" + , BuildInfo.installDirTemplates = error "BuildInfo.installDirTemplates not defined" + , BuildInfo.componentsConfigs = error "BuildInfo.componentsConfigs not defined" + , BuildInfo.installedPkgs = error "BuildInfo.installedPkgs not defined" + , BuildInfo.pkgDescrFile = error "BuildInfo.pkgDescrFile not defined" + , BuildInfo.localPkgDescr = error "BuildInfo.localPkgDescr not defined" + , BuildInfo.withVanillaLib = error "BuildInfo.withVanillaLib not defined" + , BuildInfo.withDynExe = error "BuildInfo.withDynExe not defined" + , BuildInfo.withProfExe = error "BuildInfo.withProfExe not defined" + , BuildInfo.withGHCiLib = error "BuildInfo.withGHCiLib not defined" + , BuildInfo.splitObjs = error "BuildInfo.splitObjs not defined" + , BuildInfo.stripExes = error "BuildInfo.stripExes not defined" + , BuildInfo.progPrefix = error "BuildInfo.progPrefix not defined" + , BuildInfo.progSuffix = error "BuildInfo.progSuffix not defined" + -- TODO: New fields + , BuildInfo.pkgKey = error "BuildInfo.pkgKey not defined" + , BuildInfo.instantiatedWith = error "BuildInfo.instantiatedWith not defined" + , BuildInfo.withDebugInfo = Simple.Compiler.NoDebugInfo -- must be defined + , BuildInfo.stripLibs = error "BuildInfo.stripLibs not defined" + , BuildInfo.relocatable = error "BuildInfo.relocatable not defined" + } + +-- | Run gcc via ghc, with correct parameters. +-- Copied from bits and pieces of @Distribution.Simple.GHC@. +runComponentCc :: RunCcArgs -> IO ExitCode +runComponentCc RunCcArgs{ rcPackageDBStack = configPackageDBStack + , rcExtraPathDirs = configExtraPathDirs + , rcDistDir = ideDistDir + , rcAbsC = absC + , rcAbsObj = absObj + , rcPref = pref + , rcIncludeDirs = includeDirs + , .. } = do + rcStderrLogExists <- doesFileExist rcStderrLog + when rcStderrLogExists $ removeFile rcStderrLog + + exitCode <- redirectStderr rcStderrLog $ + Ex.try $ do + createDirectoryIfMissingVerbose verbosity True odir + (ghcProg, _) <- requireProgram + verbosity Cabal.Program.ghcProgram (BuildInfo.withPrograms lbi) + let runGhcProg = GHC.runGHC verbosity ghcProg comp + runGhcProg vanillaCcOpts + + -- TH always needs default libs, even when building for profiling + -- TODO: Should we detect the use of TH in a different way? + let doingTH = Haskell.EnableExtension Haskell.TemplateHaskell + `elem` allExtensions libBi + isGhcDynamic = GHC.isDynamic comp + forceSharedLib = doingTH && isGhcDynamic + whenProfLib = when (BuildInfo.withProfLib lbi) + whenSharedLib forceShared = when (forceShared || BuildInfo.withSharedLib lbi) + + whenSharedLib forceSharedLib (runGhcProg sharedCcOpts) + whenProfLib (runGhcProg profCcOpts) + return $! either id (\() -> ExitSuccess) exitCode + where + verbosity = silent + buildDir = ideDistDir -- TODO: create dist.23412/build? see cabalMacrosLocation + lbi = localBuildInfo buildDir configPackageDBStack configExtraPathDirs + comp = BuildInfo.compiler lbi + libBi = emptyBuildInfo{includeDirs} -- TODO: set ccOptions? + odir = Setup.fromFlag (GHC.ghcOptObjDir vanillaCcOpts) + + -- a stub, this would be expensive (lookups in pkgIndex); + -- TODO: is it needed? e.g., for C calling into Haskell? + clbi = BuildInfo.LibComponentLocalBuildInfo [] [] Map.empty [] + + -- Construct CC options for various kinds of flavours + vanillaCcOpts = (GHC.componentCcGhcOptions verbosity lbi + libBi clbi pref absC) `mappend` mempty { + -- ghc ignores -odir for .o files coming from .c files + GHC.ghcOptExtra = NubList.toNubListR $ ["-o", absObj] ++ rcOptions, + GHC.ghcOptFPic = Setup.toFlag True + } + profCcOpts = vanillaCcOpts `mappend` mempty { + GHC.ghcOptProfilingMode = Setup.toFlag True, + GHC.ghcOptObjSuffix = Setup.toFlag "p_o" + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + GHC.ghcOptDynLinkMode = Setup.toFlag GHC.GhcDynamicOnly, + GHC.ghcOptObjSuffix = Setup.toFlag "dyn_o", + GHC.ghcOptExtra = NubList.toNubListR ["-o", replaceExtension absObj "dyn_o"] + } + +data BuildExeArgs = BuildExeArgs + { bePackageDBStack :: PackageDBStack + , beExtraPathDirs :: [FilePath] + , beSourcesDir :: FilePath + , beDistDir :: FilePath + , beStdoutLog :: FilePath + , beStderrLog :: FilePath + , beRelativeIncludes :: [FilePath] + , beGhcOpts :: [String] + , beLibDeps :: [Package.Dependency] + , beLoadedMs :: [ModuleName] + } + +data RunCcArgs = RunCcArgs + { rcPackageDBStack :: PackageDBStack + , rcExtraPathDirs :: [FilePath] + , rcDistDir :: FilePath + , rcStdoutLog :: FilePath + , rcStderrLog :: FilePath + , rcAbsC :: FilePath + , rcAbsObj :: FilePath + , rcPref :: FilePath + , rcIncludeDirs :: [FilePath] + , rcOptions :: [String] + } + +data LicenseArgs = LicenseArgs + { -- | 3 fields from session configuration + liPackageDBStack :: PackageDBStack + , liExtraPathDirs :: [FilePath] + , liLicenseExc :: [String] + -- | the working directory; the resulting file is written there + , liDistDir :: FilePath + , liStdoutLog :: FilePath + , liStderrLog :: FilePath + -- | see 'configLicenseFixed' + , licenseFixed :: [( String + , (Maybe License, Maybe FilePath, Maybe String) + )] + -- | the directory with all the .cabal files + , liCabalsDir :: FilePath + -- | the list of packages to process + , liPkgs :: [PackageId] + } + +data ExeCabalRequest = + ReqExeBuild BuildExeArgs [(ModuleName, FilePath)] + | ReqExeDoc BuildExeArgs + | ReqExeCc RunCcArgs + | ReqExeLic LicenseArgs + deriving Typeable + +data ExeCabalResponse = + ExeCabalProgress Progress + | ExeCabalDone ExitCode + deriving Typeable + +instance Binary ExeCabalRequest where + put (ReqExeBuild buildArgs ms) = putWord8 0 >> put buildArgs >> put ms + put (ReqExeDoc buildArgs) = putWord8 1 >> put buildArgs + put (ReqExeCc ccArgs) = putWord8 2 >> put ccArgs + put (ReqExeLic licenseArgs) = putWord8 3 >> put licenseArgs + + get = do + header <- getWord8 + case header of + 0 -> ReqExeBuild <$> get <*> get + 1 -> ReqExeDoc <$> get + 2 -> ReqExeCc <$> get + 3 -> ReqExeLic <$> get + _ -> fail "ExeCabalRequest.get: invalid header" + +instance Binary ExeCabalResponse where + put (ExeCabalProgress progress) = putWord8 0 >> put progress + put (ExeCabalDone exitCode) = putWord8 1 >> put exitCode + + get = do + header <- getWord8 + case header of + 0 -> ExeCabalProgress <$> get + 1 -> ExeCabalDone <$> get + _ -> fail "ExeCabalResponse.get: invalid header" + +instance Binary BuildExeArgs where + put BuildExeArgs{..} = do + put bePackageDBStack + put beExtraPathDirs + put beSourcesDir + put beDistDir + put beStdoutLog + put beStderrLog + put beRelativeIncludes + put beGhcOpts + put beLibDeps + put beLoadedMs + + get = BuildExeArgs <$> get <*> get <*> get + <*> get <*> get <*> get + <*> get <*> get <*> get <*> get + +instance Binary RunCcArgs where + put RunCcArgs{..} = do + put rcPackageDBStack + put rcExtraPathDirs + put rcDistDir + put rcStdoutLog + put rcStderrLog + put rcAbsC + put rcAbsObj + put rcPref + put rcIncludeDirs + put rcOptions + + get = RunCcArgs <$> get <*> get <*> get + <*> get <*> get <*> get + <*> get <*> get <*> get + <*> get + +instance Binary LicenseArgs where + put LicenseArgs{..} = do + put liPackageDBStack + put liExtraPathDirs + put liLicenseExc + put liDistDir + put liStdoutLog + put liStderrLog + put licenseFixed + put liCabalsDir + put liPkgs + + get = LicenseArgs <$> get <*> get <*> get + <*> get <*> get <*> get + <*> get <*> get <*> get + +instance Binary ExitCode where + put ExitSuccess = putWord8 0 + put (ExitFailure code) = putWord8 1 >> put code + + get = do + header <- getWord8 + case header of + 0 -> return ExitSuccess + 1 -> ExitFailure <$> get + _ -> fail "ExitCode.get: invalid header" diff --git a/IdeSession/Config.hs b/IdeSession/Config.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Config.hs @@ -0,0 +1,87 @@ +module IdeSession.Config ( + SessionConfig(..) + , InProcess + , defaultSessionConfig + ) where + +import Distribution.License (License (..)) +import Distribution.Simple (PackageDB (..), PackageDBStack) + +type InProcess = Bool + +-- | Configuration parameters for a session. These remain the same throughout +-- the whole session's lifetime. +-- +data SessionConfig = SessionConfig { + -- | The directory to use for all session files. + configDir :: FilePath + -- | Extra directories in which to look for programs, including ghc + -- and other tools. Note that the @$PATH@ is still searched /first/, these + -- directories are extra. + , configExtraPathDirs :: [FilePath] + -- | Should the GHC client run in-process? + -- NOTE: This is currently broken. Set to False. + , configInProcess :: InProcess + -- | Whether to generate module type/autocompletion info. + , configGenerateModInfo :: Bool + -- | Package DBs to consult + , configPackageDBStack :: PackageDBStack + -- | Packages that don't need the .cabal files provided for license + -- concatenation (e.g., because they are covered by the core license set). + , configLicenseExc :: [String] + -- | Hard-coded package licence information, e.g., for the packages + -- that always stay installed in-place in the GHC tree, so it's + -- troublesome to automatically retrieve their .cabal files. + , configLicenseFixed :: [( String + , (Maybe License, Maybe FilePath, Maybe String) + )] + -- | Function to be used for logging. Messages logged in this manner may be + -- provided to users in a special debugging UI. + , configLog :: String -> IO () + -- | Delete temporary files when session finishes? + -- (Defaults to True; mostly for internal debugging purposes) + , configDeleteTempFiles :: Bool + } + +-- | Default session configuration +-- +-- Use this instead of creating your own SessionConfig to be robust against +-- extensions of SessionConfig. +-- +-- > defaultSessionConfig = SessionConfig { +-- > configDir = "." +-- > , configExtraPathDirs = [] +-- > , configInProcess = False +-- > , configGenerateModInfo = True +-- > , configPackageDBStack = [GlobalPackageDB, UserPackageDB] +-- > -- ghc-prim, integer-gmp, etc., all have their own licenses specified +-- > -- in their .cabal files. +-- > , configLicenseExc = ["rts"] +-- > , configLicenseFixed = [ +-- > ("bin-package-db", (Just BSD3, Nothing, Nothing)) +-- > , ("ghc", (Just BSD3, Just "../LICENSE", Just "The GHC Team")) +-- > , ("ghc-prim", (Just BSD3, Just "LICENSE", Nothing)) +-- > , ("integer-gmp", (Just BSD3, Just "LICENSE", Nothing)) +-- > ] +-- > , configLog = const $ return () +-- > , configDeleteTempFiles = True +-- > } +defaultSessionConfig :: SessionConfig +defaultSessionConfig = SessionConfig { + configDir = "." + , configExtraPathDirs = [] + , configInProcess = False + , configGenerateModInfo = True + , configPackageDBStack = [GlobalPackageDB, UserPackageDB] + -- ghc-prim, integer-gmp, etc., all have their own licenses specified + -- in their .cabal files. + , configLicenseExc = ["rts"] + , configLicenseFixed = [ + ("bin-package-db", (Just BSD3, Nothing, Nothing)) + , ("ghc", (Just BSD3, Just "../LICENSE", Just "The GHC Team")) + , ("ghc-prim", (Just BSD3, Just "LICENSE", Nothing)) + , ("integer-gmp", (Just BSD3, Just "LICENSE", Nothing)) + ] + , configLog = const $ return () + , configDeleteTempFiles = True + } diff --git a/IdeSession/ExeCabalClient.hs b/IdeSession/ExeCabalClient.hs new file mode 100644 --- /dev/null +++ b/IdeSession/ExeCabalClient.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TupleSections #-} +-- | Invoke the executable that calls cabal functions and communicate +-- with it via RPC. +module IdeSession.ExeCabalClient ( + invokeExeCabal + ) where + +import System.Exit (ExitCode) + +import Distribution.Verbosity (normal) +import Distribution.Simple.Program.Find ( + ProgramSearchPath + , findProgramOnSearchPath + , ProgramSearchPathEntry(..) + ) + +import IdeSession.Cabal +import IdeSession.Config +import IdeSession.GHC.API +import IdeSession.RPC.Client (RpcServer, RpcConversation(..), forkRpcServer, rpcConversation, shutdown) +import IdeSession.State +import IdeSession.Types.Progress +import IdeSession.Util + +-- | Invoke the executable that processes our custom functions that use +-- the machinery of the cabal library. +invokeExeCabal :: IdeStaticInfo -> ExeCabalRequest -> (Progress -> IO ()) + -> IO ExitCode +invokeExeCabal IdeStaticInfo{..} args callback = do + mLoc <- findProgramOnSearchPath normal searchPath "ide-backend-exe-cabal" + case mLoc of + Nothing -> + fail $ "Could not find ide-backend-exe-cabal" + Just prog -> do + env <- envWithPathOverride configExtraPathDirs + let cwd = case args of + ReqExeDoc{} -> ideSessionDir + _ -> ideSessionDataDir ideSessionDir + server <- forkRpcServer prog [] (Just cwd) env + exitCode <- rpcRunExeCabal server args callback + shutdown server -- not long-running + return exitCode + where + searchPath :: ProgramSearchPath + searchPath = ProgramSearchPathDefault + : map ProgramSearchPathDir configExtraPathDirs + + SessionConfig{..} = ideConfig + +rpcRunExeCabal :: RpcServer -> ExeCabalRequest -> (Progress -> IO ()) + -> IO ExitCode +rpcRunExeCabal server req callback = + rpcConversation server $ \RpcConversation{..} -> do + put req + + let go = do response <- get + case response of + ExeCabalProgress pcounter -> callback pcounter >> go + ExeCabalDone exitCode -> return exitCode + + go diff --git a/IdeSession/GHC/API.hs b/IdeSession/GHC/API.hs new file mode 100644 --- /dev/null +++ b/IdeSession/GHC/API.hs @@ -0,0 +1,90 @@ +-- | Types for the messages to and fro the GHC server +-- +-- It is important that none of the types here rely on the GHC library. +{-# LANGUAGE DeriveDataTypeable #-} +module IdeSession.GHC.API ( + -- * Requests + module IdeSession.GHC.Requests + -- * Responses + , module IdeSession.GHC.Responses + -- * Configuration + , ideBackendApiVersion + , hsExtensions + , hsBootExtensions + , cExtensions + , cHeaderExtensions + , sourceExtensions + , cabalMacrosLocation + -- * Paths + , ideSessionSourceDir + , ideSessionDataDir + , ideSessionDistDir + , ideSessionObjDir + ) where + +import System.FilePath (()) + +import IdeSession.GHC.Requests +import IdeSession.GHC.Responses + +-- | For detecting runtime version mismatch between the server and the library +-- +-- We use a Unix timestamp for this so that these API versions have some +-- semantics (http://www.epochconverter.com/, GMT). +ideBackendApiVersion :: Int +ideBackendApiVersion = 1426765899 + +{------------------------------------------------------------------------------ + Configuration +------------------------------------------------------------------------------} + +-- | Haskell source files +hsExtensions :: [FilePath] +hsExtensions = [".hs", ".lhs"] + +-- | Haskell @.boot@ files +hsBootExtensions :: [FilePath] +hsBootExtensions = [".hs-boot", ".lhs-boot"] + +-- | C source files +cExtensions :: [FilePath] +cExtensions = [".c"] + +-- | C header files +cHeaderExtensions :: [FilePath] +cHeaderExtensions = [".h"] + +-- | Extensions of all source files we keep in our source directory. +sourceExtensions :: [FilePath] +sourceExtensions = hsExtensions + ++ hsBootExtensions + ++ cExtensions + ++ cHeaderExtensions + +-- TODO: perhaps create dist/build/autogen and put macros there so that +-- Cabal.autogenModulesDir can use it for compilation of C files? +cabalMacrosLocation :: FilePath -> FilePath +cabalMacrosLocation ideDistDir = ideDistDir "cabal_macros.h" + +{------------------------------------------------------------------------------- + Paths + + These are all meant to be relative to the session dir +-------------------------------------------------------------------------------} + +-- | The directory to use for managing source files. +ideSessionSourceDir :: FilePath -> FilePath +ideSessionSourceDir sessionDir = sessionDir "src" + +-- | The directory to use for data files that may be accessed by the +-- running program. The running program will have this as its CWD. +ideSessionDataDir :: FilePath -> FilePath +ideSessionDataDir sessionDir = sessionDir "data" + +-- | Cabal "dist" prefix. +ideSessionDistDir :: FilePath -> FilePath +ideSessionDistDir sessionDir = sessionDir "dist" + +-- | Directory where we store compiled C files (objects) +ideSessionObjDir :: FilePath -> FilePath +ideSessionObjDir sessionDir = sessionDir "ffi" diff --git a/IdeSession/GHC/Client.hs b/IdeSession/GHC/Client.hs new file mode 100644 --- /dev/null +++ b/IdeSession/GHC/Client.hs @@ -0,0 +1,361 @@ +-- | Client interface to the `ide-backend-server` process +-- +-- It is important that none of the types here rely on the GHC library. +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TupleSections #-} +module IdeSession.GHC.Client ( + -- * Starting and stopping the server + InProcess + , GhcServer(..) + , forkGhcServer + , shutdownGhcServer + , forceShutdownGhcServer + , getGhcExitCode + -- * Interacting with the server + , RunActions(..) + , runWaitAll + , rpcCompile + , rpcRun + , rpcCrash + , rpcSetEnv + , rpcSetArgs + , rpcBreakpoint + , rpcPrint + , rpcLoad + , rpcUnload + , rpcSetGhcOpts + ) where + +import Control.Applicative ((<$>)) +import Control.Concurrent (killThread) +import Control.Concurrent.Async (async, cancel, withAsync) +import Control.Concurrent.Chan (Chan, newChan, writeChan) +import Control.Concurrent.MVar (newMVar) +import Control.Monad (when, forever) +import Data.Typeable (Typeable) +import Data.Binary (Binary) +import System.Directory (removeFile) +import System.Exit (ExitCode) +import System.Posix (ProcessID, sigKILL, signalProcess) +import qualified Control.Exception as Ex +import qualified Data.ByteString.Char8 as BSS +import qualified Data.ByteString.Lazy.Char8 as BSL + +import IdeSession.Config +import IdeSession.GHC.API +import IdeSession.RPC.Client +import IdeSession.State +import IdeSession.Types.Private (RunResult(..)) +import IdeSession.Types.Progress +import IdeSession.Util +import IdeSession.Util.BlockingOps +import qualified IdeSession.Types.Public as Public + +import Distribution.Verbosity (normal) +import Distribution.Simple (PackageDB(..), PackageDBStack) +import Distribution.Simple.Program.Find ( -- From our patched cabal + ProgramSearchPath + , findProgramOnSearchPath + , ProgramSearchPathEntry(..) + ) + +{------------------------------------------------------------------------------ + Starting and stopping the server +------------------------------------------------------------------------------} + +-- | Start the ghc server +forkGhcServer :: [String] -- ^ Initial ghc options + -> [FilePath] -- ^ Relative includes + -> [String] -- ^ RTS options + -> IdeStaticInfo -- ^ Session setup info + -> IO (Either ExternalException (GhcServer, GhcVersion)) +forkGhcServer ghcOpts relIncls rtsOpts IdeStaticInfo{ideConfig, ideSessionDir} = do + when configInProcess $ + fail "In-process ghc server not currently supported" + + mLoc <- findProgramOnSearchPath normal searchPath "ide-backend-server" + case mLoc of + Nothing -> + fail $ "Could not find ide-backend-server" + Just prog -> do + env <- envWithPathOverride configExtraPathDirs + server <- OutProcess <$> forkRpcServer + prog + (["+RTS"] ++ rtsOpts ++ ["-RTS"]) + (Just (ideSessionDataDir ideSessionDir)) + env + version <- Ex.try $ do + GhcInitResponse{..} <- rpcInit server GhcInitRequest { + ghcInitClientApiVersion = ideBackendApiVersion + , ghcInitGenerateModInfo = configGenerateModInfo + , ghcInitOpts = opts + , ghcInitUserPackageDB = userDB + , ghcInitSpecificPackageDBs = specificDBs + , ghcInitSessionDir = ideSessionDir + } + return ghcInitVersion + return ((server,) <$> version) + where + (userDB, specificDBs) = splitPackageDBStack configPackageDBStack + + opts :: [String] + opts = "-XHaskell2010" -- see #190 + : ghcOpts + ++ relInclToOpts (ideSessionSourceDir ideSessionDir) relIncls + + searchPath :: ProgramSearchPath + searchPath = map ProgramSearchPathDir configExtraPathDirs + ++ [ProgramSearchPathDefault] + + SessionConfig{..} = ideConfig + +{- TODO: Reenable in-process +forkGhcServer configGenerateModInfo opts workingDir True = do + let conv a b = RpcConversation { + get = do bs <- $readChan a + case decode' bs of + Just x -> return x + Nothing -> fail "JSON failure" + , put = writeChan b . encode + } + a <- newChan + b <- newChan + tid <- forkIO $ ghcServerEngine configGenerateModInfo opts (conv a b) + return $ InProcess (conv b a) tid +-} + +splitPackageDBStack :: PackageDBStack -> (Bool, [String]) +splitPackageDBStack dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> (True, map specific dbs) + (GlobalPackageDB:dbs) -> (False, map specific dbs) + _ -> ierror + where + specific (SpecificPackageDB db) = db + specific _ = ierror + + ierror :: a + ierror = error $ "internal error: unexpected package db stack: " + ++ show dbstack + +shutdownGhcServer :: GhcServer -> IO () +shutdownGhcServer (OutProcess server) = shutdown server +shutdownGhcServer (InProcess _ tid) = killThread tid + +forceShutdownGhcServer :: GhcServer -> IO () +forceShutdownGhcServer (OutProcess server) = forceShutdown server +forceShutdownGhcServer (InProcess _ tid) = killThread tid + +getGhcExitCode :: GhcServer -> IO (Maybe ExitCode) +getGhcExitCode (OutProcess server) = + getRpcExitCode server +getGhcExitCode (InProcess _ _) = + fail "getGhcExitCode not supported for in-process server" + +{------------------------------------------------------------------------------ + Interacting with the server +------------------------------------------------------------------------------} + +-- | Repeatedly call 'runWait' until we receive a 'Right' result, while +-- collecting all 'Left' results +runWaitAll :: forall a. RunActions a -> IO (BSL.ByteString, a) +runWaitAll RunActions{runWait} = go [] + where + go :: [BSS.ByteString] -> IO (BSL.ByteString, a) + go acc = do + resp <- runWait + case resp of + Left bs -> go (bs : acc) + Right runResult -> return (BSL.fromChunks (reverse acc), runResult) + +-- | Set the environment +rpcSetEnv :: GhcServer -> [(String, Maybe String)] -> IO () +rpcSetEnv (OutProcess server) env = + rpc server (ReqSetEnv env) +rpcSetEnv (InProcess _ _) _ = + error "rpcSetEnv not supported for in-process server" + +-- | Set command line arguments +rpcSetArgs :: GhcServer -> [String] -> IO () +rpcSetArgs (OutProcess server) args = + rpc server (ReqSetArgs args) +rpcSetArgs (InProcess _ _) _ = + error "rpcSetArgs not supported for in-process server" + +-- | Set ghc options +rpcSetGhcOpts :: GhcServer -> [String] -> IO ([String], [String]) +rpcSetGhcOpts (OutProcess server) opts = + rpc server (ReqSetGhcOpts opts) +rpcSetGhcOpts (InProcess _ _) _ = + error "rpcSetGhcOpts not supported for in-process server" + +-- | Compile or typecheck +rpcCompile :: GhcServer -- ^ GHC server + -> Bool -- ^ Should we generate code? + -> Public.Targets -- ^ Targets + -> (Progress -> IO ()) -- ^ Progress callback + -> IO GhcCompileResult +rpcCompile server genCode targets callback = + ghcConversation server $ \RpcConversation{..} -> do + put (ReqCompile genCode targets) + + let go = do response <- get + case response of + GhcCompileProgress pcounter -> callback pcounter >> go + GhcCompileDone result -> return result + + go + +-- | Set breakpoint +-- +-- Returns @Just@ the old value of the break if successful, or @Nothing@ if +-- the breakpoint could not be found. +rpcBreakpoint :: GhcServer + -> Public.ModuleName -> Public.SourceSpan + -> Bool + -> IO (Maybe Bool) +rpcBreakpoint server reqBreakpointModule reqBreakpointSpan reqBreakpointValue = + ghcRpc server ReqBreakpoint{..} + +data SnippetAction = + SnippetOutput BSS.ByteString + | SnippetTerminated RunResult + | SnippetForceTerminated + +-- | Run code +-- +-- NOTE: This is an interruptible operation +rpcRun :: forall a. + GhcServer -- ^ GHC server + -> RunCmd -- ^ Run command + -> (Maybe RunResult -> IO a) -- ^ Translate run results + -- @Nothing@ indicates force cancellation + -> IO (RunActions a) +rpcRun server cmd translateResult = + Ex.mask_ $ do + -- Communicate with the snippet using an independent, concurrent, conversation + -- + -- We mask exceptions _completely_ while connecting to the server because + -- we don't want an asynchronous exception against rpcRun to interrupt + -- communication with the main server, because that would make the whole + -- session unuseable. + -- + -- TODO: This is of course a tad dangerous, because if for whatever reason + -- the communication with the main server stalls we cannot interrupt it. + -- Perhaps we should introduce a separate timeout for that? + (pid, stdin, stdout, errorLog) <- Ex.uninterruptibleMask_ $ ghcRpc server (ReqRun cmd) + + -- Unmask exceptions only once we've installed an exception handler to + -- cleanup the process again + interruptible (aux pid stdin stdout errorLog) `Ex.onException` signalProcess sigKILL pid + where + aux :: ProcessID -> FilePath -> FilePath -> FilePath -> IO (RunActions a) + aux pid stdin stdout errorLog = do + runWaitChan <- newChan :: IO (Chan SnippetAction) + reqChan <- newChan :: IO (Chan GhcRunRequest) + + respThread <- async . Ex.handle (handleExternalException runWaitChan) $ do + connectToRpcServer stdin stdout errorLog $ \server' -> + ghcConversation (OutProcess server') $ \RpcConversation{..} -> do + -- This "respThread" is responsible for reading responses from the RPC + -- conversation, and writing them to the runWaitChan channel. This thread + -- terminates when the server replies with GhcRunDone. + -- + -- In addition, we spawns a second "reqThread" which is responsible for + -- reading requests from the reqChan and sending them to to server. We + -- use withAsync so that when then we (the respThread) terminate the + -- reqThread automatically gets cancelled. + -- + -- If an exception happens in the respThread it will be written to the + -- runWaitChan and the snippet will be considered terminated. + -- + -- (TODO: What happens when an exception happens in the reqThread?) + withAsync (sendRequests put reqChan) $ \_reqThread -> do + let go = do resp <- get + case resp of + GhcRunDone result -> do + ignoreIOExceptions $ removeFile errorLog + writeChan runWaitChan (SnippetTerminated result) + GhcRunOutp bs -> do + writeChan runWaitChan (SnippetOutput bs) + go + go + + -- runActionsState is used to make sure that once a snippet has terminated, + -- any subsequent calls to runWait simply return the final result. + -- This also makes sure that we call translateResult at most once. + runActionsState <- newMVar Nothing + + return RunActions { + runWait = + $modifyMVar runActionsState $ \st -> + case st of + Just outcome -> + return (Just outcome, Right outcome) + Nothing -> do + outcome <- $readChan runWaitChan + case outcome of + SnippetOutput bs -> + return (Nothing, Left bs) + SnippetForceTerminated -> do + res <- translateResult Nothing + return (Just res, Right res) + SnippetTerminated res' -> do + res <- translateResult (Just res') + return (Just res, Right res) + , interrupt = writeChan reqChan GhcRunInterrupt + , supplyStdin = writeChan reqChan . GhcRunInput + , forceCancel = do + cancel respThread + ignoreIOExceptions $ signalProcess sigKILL pid + ignoreIOExceptions $ removeFile errorLog + writeChan runWaitChan SnippetForceTerminated + } + + sendRequests :: (GhcRunRequest -> IO ()) -> Chan GhcRunRequest -> IO () + sendRequests put reqChan = forever $ put =<< $readChan reqChan + + -- TODO: should we restart the session when ghc crashes? + -- Maybe recommend that the session is started on GhcExceptions? + handleExternalException :: Chan SnippetAction + -> ExternalException + -> IO () + handleExternalException ch = + writeChan ch . SnippetTerminated . RunGhcException . show + +-- | Print a variable +rpcPrint :: GhcServer -> Public.Name -> Bool -> Bool -> IO Public.VariableEnv +rpcPrint server var bind forceEval = ghcRpc server (ReqPrint var bind forceEval) + +-- | Load an object file +rpcLoad :: GhcServer -> [FilePath] -> IO (Maybe String) +rpcLoad server objects = ghcRpc server (ReqLoad objects) + +-- | Unload an object file +rpcUnload :: GhcServer -> [FilePath] -> IO () +rpcUnload server objects = ghcRpc server (ReqUnload objects) + +-- | Crash the GHC server (for debugging purposes) +rpcCrash :: GhcServer -> Maybe Int -> IO () +rpcCrash server delay = ghcConversation server $ \RpcConversation{..} -> + put (ReqCrash delay) + +-- | Handshake with the server +rpcInit :: GhcServer -> GhcInitRequest -> IO GhcInitResponse +rpcInit = ghcRpc + +{------------------------------------------------------------------------------ + Internal +------------------------------------------------------------------------------} + +ghcConversation :: GhcServer -> (RpcConversation -> IO a) -> IO a +ghcConversation (OutProcess server) = rpcConversation server +ghcConversation (InProcess conv _) = ($ conv) + +ghcRpc :: (Typeable req, Typeable resp, Binary req, Binary resp) + => GhcServer -> req -> IO resp +ghcRpc (OutProcess server) = rpc server +ghcRpc (InProcess _ _) = error "ghcRpc not implemented for in-process server" + +ignoreIOExceptions :: IO () -> IO () +ignoreIOExceptions = let handler :: Ex.IOException -> IO () + handler _ = return () + in Ex.handle handler diff --git a/IdeSession/GHC/Requests.hs b/IdeSession/GHC/Requests.hs new file mode 100644 --- /dev/null +++ b/IdeSession/GHC/Requests.hs @@ -0,0 +1,192 @@ +-- | GHC requests +-- +-- GHC requests use "IdeSession.Types.Public" types. +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} +module IdeSession.GHC.Requests ( + GhcInitRequest(..) + , GhcRequest(..) + , GhcRunRequest(..) + , RunCmd(..) + ) where + +import Data.Binary +import Data.ByteString (ByteString) +import Data.Typeable (Typeable) +import Control.Applicative ((<$>), (<*>)) + +import Text.Show.Pretty (PrettyVal(..)) +import GHC.Generics + +import IdeSession.Types.Public + +-- | Initial handshake with the ghc server +-- +-- Ideally we'd send over the entire IdeStaticInfo but this includes some +-- Cabal fields, and the ghc server does -not- compile against Cabal +-- (although this isn't so important anymore now that we use Cabal-ide-backend) +data GhcInitRequest = GhcInitRequest { + ghcInitClientApiVersion :: Int + , ghcInitGenerateModInfo :: Bool + , ghcInitOpts :: [String] + , ghcInitUserPackageDB :: Bool + , ghcInitSpecificPackageDBs :: [String] + , ghcInitSessionDir :: FilePath + } + deriving (Typeable, Generic) + +data GhcRequest + = ReqCompile { + reqCompileGenCode :: Bool + , reqCompileTargets :: Targets + } + | ReqRun { + reqRunCmd :: RunCmd + } + | ReqSetEnv { + reqSetEnv :: [(String, Maybe String)] + } + | ReqSetArgs { + reqSetArgs :: [String] + } + | ReqBreakpoint { + reqBreakpointModule :: ModuleName + , reqBreakpointSpan :: SourceSpan + , reqBreakpointValue :: Bool + } + | ReqPrint { + reqPrintVars :: Name + , reqPrintBind :: Bool + , reqPrintForce :: Bool + } + | ReqLoad { + reqLoad :: [FilePath] + } + | ReqUnload { + reqUnload :: [FilePath] + } + | ReqSetGhcOpts { + reqSetGhcOpts :: [String] + } + -- | For debugging only! :) + | ReqCrash { + reqCrashDelay :: Maybe Int + } + deriving (Typeable, Generic, Show) + +data RunCmd = + RunStmt { + runCmdModule :: String + , runCmdFunction :: String + , runCmdStdout :: RunBufferMode + , runCmdStderr :: RunBufferMode + } + | Resume + deriving (Typeable, Generic, Show) + +instance PrettyVal GhcInitRequest +instance PrettyVal GhcRequest +instance PrettyVal RunCmd + +data GhcRunRequest = + GhcRunInput ByteString + | GhcRunInterrupt + deriving Typeable + +instance Binary GhcInitRequest where + put (GhcInitRequest{..}) = do + -- Note: we intentionally write the API version first. This makes it + -- possible (in theory at least) to have some form of backwards API + -- compatibility. + put ghcInitClientApiVersion + put ghcInitGenerateModInfo + put ghcInitOpts + put ghcInitUserPackageDB + put ghcInitSpecificPackageDBs + put ghcInitSessionDir + + get = GhcInitRequest <$> get + <*> get + <*> get + <*> get + <*> get + <*> get + +instance Binary GhcRequest where + put ReqCompile{..} = do + putWord8 0 + put reqCompileGenCode + put reqCompileTargets + put ReqRun{..} = do + putWord8 1 + put reqRunCmd + put ReqSetEnv{..} = do + putWord8 2 + put reqSetEnv + put ReqSetArgs{..} = do + putWord8 3 + put reqSetArgs + put ReqBreakpoint{..} = do + putWord8 4 + put reqBreakpointModule + put reqBreakpointSpan + put reqBreakpointValue + put ReqPrint{..} = do + putWord8 5 + put reqPrintVars + put reqPrintBind + put reqPrintForce + put ReqLoad{..} = do + putWord8 6 + put reqLoad + put ReqUnload{..} = do + putWord8 7 + put reqUnload + put ReqSetGhcOpts{..} = do + putWord8 8 + put reqSetGhcOpts + put ReqCrash{..} = do + putWord8 255 + put reqCrashDelay + + get = do + header <- getWord8 + case header of + 0 -> ReqCompile <$> get <*> get + 1 -> ReqRun <$> get + 2 -> ReqSetEnv <$> get + 3 -> ReqSetArgs <$> get + 4 -> ReqBreakpoint <$> get <*> get <*> get + 5 -> ReqPrint <$> get <*> get <*> get + 6 -> ReqLoad <$> get + 7 -> ReqUnload <$> get + 8 -> ReqSetGhcOpts <$> get + 255 -> ReqCrash <$> get + _ -> fail "GhcRequest.get: invalid header" + +instance Binary RunCmd where + put (RunStmt {..}) = do + putWord8 0 + put runCmdModule + put runCmdFunction + put runCmdStdout + put runCmdStderr + put Resume = do + putWord8 1 + + get = do + header <- getWord8 + case header of + 0 -> RunStmt <$> get <*> get <*> get <*> get + 1 -> return Resume + _ -> fail "RunCmd.get: invalid header" + +instance Binary GhcRunRequest where + put (GhcRunInput bs) = putWord8 0 >> put bs + put GhcRunInterrupt = putWord8 1 + + get = do + header <- getWord8 + case header of + 0 -> GhcRunInput <$> get + 1 -> return GhcRunInterrupt + _ -> fail "GhcRunRequest.get: invalid header" diff --git a/IdeSession/GHC/Responses.hs b/IdeSession/GHC/Responses.hs new file mode 100644 --- /dev/null +++ b/IdeSession/GHC/Responses.hs @@ -0,0 +1,127 @@ +-- | Responses from the GHC server +-- +-- The server responds with "IdeSession.Types.Private" types +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} +module IdeSession.GHC.Responses ( + GhcInitResponse(..) + , GhcCompileResponse(..) + , GhcCompileResult(..) + , GhcRunResponse(..) + , GhcVersion(..) + ) where + +import Data.Binary +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Control.Applicative ((<$>), (<*>)) + +import IdeSession.Types.Private +import IdeSession.Types.Progress +import IdeSession.Strict.Container +import IdeSession.Util (Diff) + +import Text.Show.Pretty +import GHC.Generics + +data GhcInitResponse = GhcInitResponse { + ghcInitVersion :: GhcVersion + } + deriving (Typeable, Generic) + +data GhcCompileResponse = + GhcCompileProgress Progress + | GhcCompileDone GhcCompileResult + deriving (Typeable, Generic) + +-- NOTE: These fields cannot be made strict (at least, not easily) +data GhcCompileResult = GhcCompileResult { + ghcCompileErrors :: Strict [] SourceError + , ghcCompileLoaded :: Strict [] ModuleName + , ghcCompileCache :: ExplicitSharingCache + -- Computed from the GhcSummary (independent of the plugin, and hence + -- available even when the plugin does not run) + , ghcCompileFileMap :: Strict (Map FilePath) ModuleId + , ghcCompileImports :: Strict (Map ModuleName) (Diff (Strict [] Import)) + , ghcCompileAuto :: Strict (Map ModuleName) (Diff (Strict [] IdInfo)) + -- Computed by the plugin + , ghcCompileSpanInfo :: Strict (Map ModuleName) (Diff IdList) + , ghcCompilePkgDeps :: Strict (Map ModuleName) (Diff (Strict [] PackageId)) + , ghcCompileExpTypes :: Strict (Map ModuleName) (Diff [(SourceSpan, Text)]) + , ghcCompileUseSites :: Strict (Map ModuleName) (Diff UseSites) + } + deriving (Typeable, Generic) + +data GhcRunResponse = + GhcRunOutp ByteString + | GhcRunDone RunResult + deriving (Typeable, Generic) + +-- | GHC version +-- +-- NOTE: Defined in such a way that the Ord instance makes sense. +data GhcVersion = GHC_7_4 | GHC_7_8 | GHC_7_10 + deriving (Typeable, Show, Eq, Ord, Generic) + +instance PrettyVal GhcInitResponse +instance PrettyVal GhcCompileResponse +instance PrettyVal GhcCompileResult +instance PrettyVal GhcRunResponse +instance PrettyVal GhcVersion + +instance Binary GhcInitResponse where + put (GhcInitResponse{..}) = do + put ghcInitVersion + get = GhcInitResponse <$> get + +instance Binary GhcCompileResponse where + put (GhcCompileProgress progress) = putWord8 0 >> put progress + put (GhcCompileDone result) = putWord8 1 >> put result + + get = do + header <- getWord8 + case header of + 0 -> GhcCompileProgress <$> get + 1 -> GhcCompileDone <$> get + _ -> fail "GhcCompileRespone.get: invalid header" + +instance Binary GhcCompileResult where + put GhcCompileResult{..} = do + put ghcCompileErrors + put ghcCompileLoaded + put ghcCompileCache + put ghcCompileFileMap + put ghcCompileImports + put ghcCompileAuto + put ghcCompileSpanInfo + put ghcCompilePkgDeps + put ghcCompileExpTypes + put ghcCompileUseSites + + get = GhcCompileResult <$> get <*> get <*> get + <*> get <*> get <*> get + <*> get <*> get <*> get <*> get + +instance Binary GhcRunResponse where + put (GhcRunOutp bs) = putWord8 0 >> put bs + put (GhcRunDone r) = putWord8 1 >> put r + + get = do + header <- getWord8 + case header of + 0 -> GhcRunOutp <$> get + 1 -> GhcRunDone <$> get + _ -> fail "GhcRunResponse.get: invalid header" + +instance Binary GhcVersion where + put GHC_7_4 = putWord8 0 + put GHC_7_8 = putWord8 1 + put GHC_7_10 = putWord8 2 + + get = do + header <- getWord8 + case header of + 0 -> return GHC_7_4 + 1 -> return GHC_7_8 + 2 -> return GHC_7_10 + _ -> fail "GhcVersion.get: invalid header" diff --git a/IdeSession/Licenses.hs b/IdeSession/Licenses.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Licenses.hs @@ -0,0 +1,1929 @@ +-- Copied form newest Cabal sources as of Fri May 31 20:40:42 2013. +-- TODO: Remove if/when this is made available thorugh the Cabal API. +module IdeSession.Licenses + ( License + , bsd3 + , gplv2 + , gplv3 + , lgpl2 + , lgpl3 + , apache20 + ) where + +type License = String + +bsd3 :: String -> String -> License +bsd3 authors year = unlines + [ "Copyright (c) " ++ year ++ ", " ++ authors + , "" + , "All rights reserved." + , "" + , "Redistribution and use in source and binary forms, with or without" + , "modification, are permitted provided that the following conditions are met:" + , "" + , " * Redistributions of source code must retain the above copyright" + , " notice, this list of conditions and the following disclaimer." + , "" + , " * Redistributions in binary form must reproduce the above" + , " copyright notice, this list of conditions and the following" + , " disclaimer in the documentation and/or other materials provided" + , " with the distribution." + , "" + , " * Neither the name of " ++ authors ++ " nor the names of other" + , " contributors may be used to endorse or promote products derived" + , " from this software without specific prior written permission." + , "" + , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS" + , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT" + , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR" + , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT" + , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," + , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT" + , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE," + , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY" + , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT" + , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE" + , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." + ] + +gplv2 :: License +gplv2 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 2, June 1991" + , "" + , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "License is intended to guarantee your freedom to share and change free" + , "software--to make sure the software is free for all its users. This" + , "General Public License applies to most of the Free Software" + , "Foundation's software and to any other program whose authors commit to" + , "using it. (Some other Free Software Foundation software is covered by" + , "the GNU Lesser General Public License instead.) You can apply it to" + , "your programs, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "this service if you wish), that you receive source code or can get it" + , "if you want it, that you can change the software or use pieces of it" + , "in new free programs; and that you know you can do these things." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "anyone to deny you these rights or to ask you to surrender the rights." + , "These restrictions translate to certain responsibilities for you if you" + , "distribute copies of the software, or if you modify it." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must give the recipients all the rights that" + , "you have. You must make sure that they, too, receive or can get the" + , "source code. And you must show them these terms so they know their" + , "rights." + , "" + , " We protect your rights with two steps: (1) copyright the software, and" + , "(2) offer you this license which gives you legal permission to copy," + , "distribute and/or modify the software." + , "" + , " Also, for each author's protection and ours, we want to make certain" + , "that everyone understands that there is no warranty for this free" + , "software. If the software is modified by someone else and passed on, we" + , "want its recipients to know that what they have is not the original, so" + , "that any problems introduced by others will not reflect on the original" + , "authors' reputations." + , "" + , " Finally, any free program is threatened constantly by software" + , "patents. We wish to avoid the danger that redistributors of a free" + , "program will individually obtain patent licenses, in effect making the" + , "program proprietary. To prevent this, we have made it clear that any" + , "patent must be licensed for everyone's free use or not licensed at all." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " GNU GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License applies to any program or other work which contains" + , "a notice placed by the copyright holder saying it may be distributed" + , "under the terms of this General Public License. The \"Program\", below," + , "refers to any such program or work, and a \"work based on the Program\"" + , "means either the Program or any derivative work under copyright law:" + , "that is to say, a work containing the Program or a portion of it," + , "either verbatim or with modifications and/or translated into another" + , "language. (Hereinafter, translation is included without limitation in" + , "the term \"modification\".) Each licensee is addressed as \"you\"." + , "" + , "Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running the Program is not restricted, and the output from the Program" + , "is covered only if its contents constitute a work based on the" + , "Program (independent of having been made by running the Program)." + , "Whether that is true depends on what the Program does." + , "" + , " 1. You may copy and distribute verbatim copies of the Program's" + , "source code as you receive it, in any medium, provided that you" + , "conspicuously and appropriately publish on each copy an appropriate" + , "copyright notice and disclaimer of warranty; keep intact all the" + , "notices that refer to this License and to the absence of any warranty;" + , "and give any other recipients of the Program a copy of this License" + , "along with the Program." + , "" + , "You may charge a fee for the physical act of transferring a copy, and" + , "you may at your option offer warranty protection in exchange for a fee." + , "" + , " 2. You may modify your copy or copies of the Program or any portion" + , "of it, thus forming a work based on the Program, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) You must cause the modified files to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " b) You must cause any work that you distribute or publish, that in" + , " whole or in part contains or is derived from the Program or any" + , " part thereof, to be licensed as a whole at no charge to all third" + , " parties under the terms of this License." + , "" + , " c) If the modified program normally reads commands interactively" + , " when run, you must cause it, when started running for such" + , " interactive use in the most ordinary way, to print or display an" + , " announcement including an appropriate copyright notice and a" + , " notice that there is no warranty (or else, saying that you provide" + , " a warranty) and that users may redistribute the program under" + , " these conditions, and telling the user how to view a copy of this" + , " License. (Exception: if the Program itself is interactive but" + , " does not normally print such an announcement, your work based on" + , " the Program is not required to print an announcement.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Program," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Program, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Program." + , "" + , "In addition, mere aggregation of another work not based on the Program" + , "with the Program (or with a work based on the Program) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may copy and distribute the Program (or a work based on it," + , "under Section 2) in object code or executable form under the terms of" + , "Sections 1 and 2 above provided that you also do one of the following:" + , "" + , " a) Accompany it with the complete corresponding machine-readable" + , " source code, which must be distributed under the terms of Sections" + , " 1 and 2 above on a medium customarily used for software interchange; or," + , "" + , " b) Accompany it with a written offer, valid for at least three" + , " years, to give any third party, for a charge no more than your" + , " cost of physically performing source distribution, a complete" + , " machine-readable copy of the corresponding source code, to be" + , " distributed under the terms of Sections 1 and 2 above on a medium" + , " customarily used for software interchange; or," + , "" + , " c) Accompany it with the information you received as to the offer" + , " to distribute corresponding source code. (This alternative is" + , " allowed only for noncommercial distribution and only if you" + , " received the program in object code or executable form with such" + , " an offer, in accord with Subsection b above.)" + , "" + , "The source code for a work means the preferred form of the work for" + , "making modifications to it. For an executable work, complete source" + , "code means all the source code for all modules it contains, plus any" + , "associated interface definition files, plus the scripts used to" + , "control compilation and installation of the executable. However, as a" + , "special exception, the source code distributed need not include" + , "anything that is normally distributed (in either source or binary" + , "form) with the major components (compiler, kernel, and so on) of the" + , "operating system on which the executable runs, unless that component" + , "itself accompanies the executable." + , "" + , "If distribution of executable or object code is made by offering" + , "access to copy from a designated place, then offering equivalent" + , "access to copy the source code from the same place counts as" + , "distribution of the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 4. You may not copy, modify, sublicense, or distribute the Program" + , "except as expressly provided under this License. Any attempt" + , "otherwise to copy, modify, sublicense or distribute the Program is" + , "void, and will automatically terminate your rights under this License." + , "However, parties who have received copies, or rights, from you under" + , "this License will not have their licenses terminated so long as such" + , "parties remain in full compliance." + , "" + , " 5. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Program or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Program (or any work based on the" + , "Program), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Program or works based on it." + , "" + , " 6. Each time you redistribute the Program (or any work based on the" + , "Program), the recipient automatically receives a license from the" + , "original licensor to copy, distribute or modify the Program subject to" + , "these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties to" + , "this License." + , "" + , " 7. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Program at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Program by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Program." + , "" + , "If any portion of this section is held invalid or unenforceable under" + , "any particular circumstance, the balance of the section is intended to" + , "apply and the section as a whole is intended to apply in other" + , "circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system, which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 8. If the distribution and/or use of the Program is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Program under this License" + , "may add an explicit geographical distribution limitation excluding" + , "those countries, so that distribution is permitted only in or among" + , "countries not thus excluded. In such case, this License incorporates" + , "the limitation as if written in the body of this License." + , "" + , " 9. The Free Software Foundation may publish revised and/or new versions" + , "of the General Public License from time to time. Such new versions will" + , "be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , "Each version is given a distinguishing version number. If the Program" + , "specifies a version number of this License which applies to it and \"any" + , "later version\", you have the option of following the terms and conditions" + , "either of that version or of any later version published by the Free" + , "Software Foundation. If the Program does not specify a version number of" + , "this License, you may choose any version ever published by the Free Software" + , "Foundation." + , "" + , " 10. If you wish to incorporate parts of the Program into other free" + , "programs whose distribution conditions are different, write to the author" + , "to ask for permission. For software which is copyrighted by the Free" + , "Software Foundation, write to the Free Software Foundation; we sometimes" + , "make exceptions for this. Our decision will be guided by the two goals" + , "of preserving the free status of all derivatives of our free software and" + , "of promoting the sharing and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY" + , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN" + , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES" + , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED" + , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF" + , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS" + , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE" + , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING," + , "REPAIR OR CORRECTION." + , "" + , " 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR" + , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES," + , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING" + , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED" + , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY" + , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER" + , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE" + , "POSSIBILITY OF SUCH DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "convey the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software; you can redistribute it and/or modify" + , " it under the terms of the GNU General Public License as published by" + , " the Free Software Foundation; either version 2 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License along" + , " with this program; if not, write to the Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "If the program is interactive, make it output a short notice like this" + , "when it starts in an interactive mode:" + , "" + , " Gnomovision version 69, Copyright (C) year name of author" + , " Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, the commands you use may" + , "be called something other than `show w' and `show c'; they could even be" + , "mouse-clicks or menu items--whatever suits your program." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the program, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the program" + , " `Gnomovision' (which makes passes at compilers) written by James Hacker." + , "" + , " , 1 April 1989" + , " Ty Coon, President of Vice" + , "" + , "This General Public License does not permit incorporating your program into" + , "proprietary programs. If your program is a subroutine library, you may" + , "consider it more useful to permit linking proprietary applications with the" + , "library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License." + ] + +gplv3 :: License +gplv3 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The GNU General Public License is a free, copyleft license for" + , "software and other kinds of works." + , "" + , " The licenses for most software and other practical works are designed" + , "to take away your freedom to share and change the works. By contrast," + , "the GNU General Public License is intended to guarantee your freedom to" + , "share and change all versions of a program--to make sure it remains free" + , "software for all its users. We, the Free Software Foundation, use the" + , "GNU General Public License for most of our software; it applies also to" + , "any other work released this way by its authors. You can apply it to" + , "your programs, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "them if you wish), that you receive source code or can get it if you" + , "want it, that you can change the software or use pieces of it in new" + , "free programs, and that you know you can do these things." + , "" + , " To protect your rights, we need to prevent others from denying you" + , "these rights or asking you to surrender the rights. Therefore, you have" + , "certain responsibilities if you distribute copies of the software, or if" + , "you modify it: responsibilities to respect the freedom of others." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must pass on to the recipients the same" + , "freedoms that you received. You must make sure that they, too, receive" + , "or can get the source code. And you must show them these terms so they" + , "know their rights." + , "" + , " Developers that use the GNU GPL protect your rights with two steps:" + , "(1) assert copyright on the software, and (2) offer you this License" + , "giving you legal permission to copy, distribute and/or modify it." + , "" + , " For the developers' and authors' protection, the GPL clearly explains" + , "that there is no warranty for this free software. For both users' and" + , "authors' sake, the GPL requires that modified versions be marked as" + , "changed, so that their problems will not be attributed erroneously to" + , "authors of previous versions." + , "" + , " Some devices are designed to deny users access to install or run" + , "modified versions of the software inside them, although the manufacturer" + , "can do so. This is fundamentally incompatible with the aim of" + , "protecting users' freedom to change the software. The systematic" + , "pattern of such abuse occurs in the area of products for individuals to" + , "use, which is precisely where it is most unacceptable. Therefore, we" + , "have designed this version of the GPL to prohibit the practice for those" + , "products. If such problems arise substantially in other domains, we" + , "stand ready to extend this provision to those domains in future versions" + , "of the GPL, as needed to protect the freedom of users." + , "" + , " Finally, every program is threatened constantly by software patents." + , "States should not allow patents to restrict development and use of" + , "software on general-purpose computers, but in those that do, we wish to" + , "avoid the special danger that patents applied to a free program could" + , "make it effectively proprietary. To prevent this, the GPL assures that" + , "patents cannot be used to render the program non-free." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " TERMS AND CONDITIONS" + , "" + , " 0. Definitions." + , "" + , " \"This License\" refers to version 3 of the GNU General Public License." + , "" + , " \"Copyright\" also means copyright-like laws that apply to other kinds of" + , "works, such as semiconductor masks." + , " " + , " \"The Program\" refers to any copyrightable work licensed under this" + , "License. Each licensee is addressed as \"you\". \"Licensees\" and" + , "\"recipients\" may be individuals or organizations." + , "" + , " To \"modify\" a work means to copy from or adapt all or part of the work" + , "in a fashion requiring copyright permission, other than the making of an" + , "exact copy. The resulting work is called a \"modified version\" of the" + , "earlier work or a work \"based on\" the earlier work." + , "" + , " A \"covered work\" means either the unmodified Program or a work based" + , "on the Program." + , "" + , " To \"propagate\" a work means to do anything with it that, without" + , "permission, would make you directly or secondarily liable for" + , "infringement under applicable copyright law, except executing it on a" + , "computer or modifying a private copy. Propagation includes copying," + , "distribution (with or without modification), making available to the" + , "public, and in some countries other activities as well." + , "" + , " To \"convey\" a work means any kind of propagation that enables other" + , "parties to make or receive copies. Mere interaction with a user through" + , "a computer network, with no transfer of a copy, is not conveying." + , "" + , " An interactive user interface displays \"Appropriate Legal Notices\"" + , "to the extent that it includes a convenient and prominently visible" + , "feature that (1) displays an appropriate copyright notice, and (2)" + , "tells the user that there is no warranty for the work (except to the" + , "extent that warranties are provided), that licensees may convey the" + , "work under this License, and how to view a copy of this License. If" + , "the interface presents a list of user commands or options, such as a" + , "menu, a prominent item in the list meets this criterion." + , "" + , " 1. Source Code." + , "" + , " The \"source code\" for a work means the preferred form of the work" + , "for making modifications to it. \"Object code\" means any non-source" + , "form of a work." + , "" + , " A \"Standard Interface\" means an interface that either is an official" + , "standard defined by a recognized standards body, or, in the case of" + , "interfaces specified for a particular programming language, one that" + , "is widely used among developers working in that language." + , "" + , " The \"System Libraries\" of an executable work include anything, other" + , "than the work as a whole, that (a) is included in the normal form of" + , "packaging a Major Component, but which is not part of that Major" + , "Component, and (b) serves only to enable use of the work with that" + , "Major Component, or to implement a Standard Interface for which an" + , "implementation is available to the public in source code form. A" + , "\"Major Component\", in this context, means a major essential component" + , "(kernel, window system, and so on) of the specific operating system" + , "(if any) on which the executable work runs, or a compiler used to" + , "produce the work, or an object code interpreter used to run it." + , "" + , " The \"Corresponding Source\" for a work in object code form means all" + , "the source code needed to generate, install, and (for an executable" + , "work) run the object code and to modify the work, including scripts to" + , "control those activities. However, it does not include the work's" + , "System Libraries, or general-purpose tools or generally available free" + , "programs which are used unmodified in performing those activities but" + , "which are not part of the work. For example, Corresponding Source" + , "includes interface definition files associated with source files for" + , "the work, and the source code for shared libraries and dynamically" + , "linked subprograms that the work is specifically designed to require," + , "such as by intimate data communication or control flow between those" + , "subprograms and other parts of the work." + , "" + , " The Corresponding Source need not include anything that users" + , "can regenerate automatically from other parts of the Corresponding" + , "Source." + , "" + , " The Corresponding Source for a work in source code form is that" + , "same work." + , "" + , " 2. Basic Permissions." + , "" + , " All rights granted under this License are granted for the term of" + , "copyright on the Program, and are irrevocable provided the stated" + , "conditions are met. This License explicitly affirms your unlimited" + , "permission to run the unmodified Program. The output from running a" + , "covered work is covered by this License only if the output, given its" + , "content, constitutes a covered work. This License acknowledges your" + , "rights of fair use or other equivalent, as provided by copyright law." + , "" + , " You may make, run and propagate covered works that you do not" + , "convey, without conditions so long as your license otherwise remains" + , "in force. You may convey covered works to others for the sole purpose" + , "of having them make modifications exclusively for you, or provide you" + , "with facilities for running those works, provided that you comply with" + , "the terms of this License in conveying all material for which you do" + , "not control copyright. Those thus making or running the covered works" + , "for you must do so exclusively on your behalf, under your direction" + , "and control, on terms that prohibit them from making any copies of" + , "your copyrighted material outside their relationship with you." + , "" + , " Conveying under any other circumstances is permitted solely under" + , "the conditions stated below. Sublicensing is not allowed; section 10" + , "makes it unnecessary." + , "" + , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." + , "" + , " No covered work shall be deemed part of an effective technological" + , "measure under any applicable law fulfilling obligations under article" + , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" + , "similar laws prohibiting or restricting circumvention of such" + , "measures." + , "" + , " When you convey a covered work, you waive any legal power to forbid" + , "circumvention of technological measures to the extent such circumvention" + , "is effected by exercising rights under this License with respect to" + , "the covered work, and you disclaim any intention to limit operation or" + , "modification of the work as a means of enforcing, against the work's" + , "users, your or third parties' legal rights to forbid circumvention of" + , "technological measures." + , "" + , " 4. Conveying Verbatim Copies." + , "" + , " You may convey verbatim copies of the Program's source code as you" + , "receive it, in any medium, provided that you conspicuously and" + , "appropriately publish on each copy an appropriate copyright notice;" + , "keep intact all notices stating that this License and any" + , "non-permissive terms added in accord with section 7 apply to the code;" + , "keep intact all notices of the absence of any warranty; and give all" + , "recipients a copy of this License along with the Program." + , "" + , " You may charge any price or no price for each copy that you convey," + , "and you may offer support or warranty protection for a fee." + , "" + , " 5. Conveying Modified Source Versions." + , "" + , " You may convey a work based on the Program, or the modifications to" + , "produce it from the Program, in the form of source code under the" + , "terms of section 4, provided that you also meet all of these conditions:" + , "" + , " a) The work must carry prominent notices stating that you modified" + , " it, and giving a relevant date." + , "" + , " b) The work must carry prominent notices stating that it is" + , " released under this License and any conditions added under section" + , " 7. This requirement modifies the requirement in section 4 to" + , " \"keep intact all notices\"." + , "" + , " c) You must license the entire work, as a whole, under this" + , " License to anyone who comes into possession of a copy. This" + , " License will therefore apply, along with any applicable section 7" + , " additional terms, to the whole of the work, and all its parts," + , " regardless of how they are packaged. This License gives no" + , " permission to license the work in any other way, but it does not" + , " invalidate such permission if you have separately received it." + , "" + , " d) If the work has interactive user interfaces, each must display" + , " Appropriate Legal Notices; however, if the Program has interactive" + , " interfaces that do not display Appropriate Legal Notices, your" + , " work need not make them do so." + , "" + , " A compilation of a covered work with other separate and independent" + , "works, which are not by their nature extensions of the covered work," + , "and which are not combined with it such as to form a larger program," + , "in or on a volume of a storage or distribution medium, is called an" + , "\"aggregate\" if the compilation and its resulting copyright are not" + , "used to limit the access or legal rights of the compilation's users" + , "beyond what the individual works permit. Inclusion of a covered work" + , "in an aggregate does not cause this License to apply to the other" + , "parts of the aggregate." + , "" + , " 6. Conveying Non-Source Forms." + , "" + , " You may convey a covered work in object code form under the terms" + , "of sections 4 and 5, provided that you also convey the" + , "machine-readable Corresponding Source under the terms of this License," + , "in one of these ways:" + , "" + , " a) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by the" + , " Corresponding Source fixed on a durable physical medium" + , " customarily used for software interchange." + , "" + , " b) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by a" + , " written offer, valid for at least three years and valid for as" + , " long as you offer spare parts or customer support for that product" + , " model, to give anyone who possesses the object code either (1) a" + , " copy of the Corresponding Source for all the software in the" + , " product that is covered by this License, on a durable physical" + , " medium customarily used for software interchange, for a price no" + , " more than your reasonable cost of physically performing this" + , " conveying of source, or (2) access to copy the" + , " Corresponding Source from a network server at no charge." + , "" + , " c) Convey individual copies of the object code with a copy of the" + , " written offer to provide the Corresponding Source. This" + , " alternative is allowed only occasionally and noncommercially, and" + , " only if you received the object code with such an offer, in accord" + , " with subsection 6b." + , "" + , " d) Convey the object code by offering access from a designated" + , " place (gratis or for a charge), and offer equivalent access to the" + , " Corresponding Source in the same way through the same place at no" + , " further charge. You need not require recipients to copy the" + , " Corresponding Source along with the object code. If the place to" + , " copy the object code is a network server, the Corresponding Source" + , " may be on a different server (operated by you or a third party)" + , " that supports equivalent copying facilities, provided you maintain" + , " clear directions next to the object code saying where to find the" + , " Corresponding Source. Regardless of what server hosts the" + , " Corresponding Source, you remain obligated to ensure that it is" + , " available for as long as needed to satisfy these requirements." + , "" + , " e) Convey the object code using peer-to-peer transmission, provided" + , " you inform other peers where the object code and Corresponding" + , " Source of the work are being offered to the general public at no" + , " charge under subsection 6d." + , "" + , " A separable portion of the object code, whose source code is excluded" + , "from the Corresponding Source as a System Library, need not be" + , "included in conveying the object code work." + , "" + , " A \"User Product\" is either (1) a \"consumer product\", which means any" + , "tangible personal property which is normally used for personal, family," + , "or household purposes, or (2) anything designed or sold for incorporation" + , "into a dwelling. In determining whether a product is a consumer product," + , "doubtful cases shall be resolved in favor of coverage. For a particular" + , "product received by a particular user, \"normally used\" refers to a" + , "typical or common use of that class of product, regardless of the status" + , "of the particular user or of the way in which the particular user" + , "actually uses, or expects or is expected to use, the product. A product" + , "is a consumer product regardless of whether the product has substantial" + , "commercial, industrial or non-consumer uses, unless such uses represent" + , "the only significant mode of use of the product." + , "" + , " \"Installation Information\" for a User Product means any methods," + , "procedures, authorization keys, or other information required to install" + , "and execute modified versions of a covered work in that User Product from" + , "a modified version of its Corresponding Source. The information must" + , "suffice to ensure that the continued functioning of the modified object" + , "code is in no case prevented or interfered with solely because" + , "modification has been made." + , "" + , " If you convey an object code work under this section in, or with, or" + , "specifically for use in, a User Product, and the conveying occurs as" + , "part of a transaction in which the right of possession and use of the" + , "User Product is transferred to the recipient in perpetuity or for a" + , "fixed term (regardless of how the transaction is characterized), the" + , "Corresponding Source conveyed under this section must be accompanied" + , "by the Installation Information. But this requirement does not apply" + , "if neither you nor any third party retains the ability to install" + , "modified object code on the User Product (for example, the work has" + , "been installed in ROM)." + , "" + , " The requirement to provide Installation Information does not include a" + , "requirement to continue to provide support service, warranty, or updates" + , "for a work that has been modified or installed by the recipient, or for" + , "the User Product in which it has been modified or installed. Access to a" + , "network may be denied when the modification itself materially and" + , "adversely affects the operation of the network or violates the rules and" + , "protocols for communication across the network." + , "" + , " Corresponding Source conveyed, and Installation Information provided," + , "in accord with this section must be in a format that is publicly" + , "documented (and with an implementation available to the public in" + , "source code form), and must require no special password or key for" + , "unpacking, reading or copying." + , "" + , " 7. Additional Terms." + , "" + , " \"Additional permissions\" are terms that supplement the terms of this" + , "License by making exceptions from one or more of its conditions." + , "Additional permissions that are applicable to the entire Program shall" + , "be treated as though they were included in this License, to the extent" + , "that they are valid under applicable law. If additional permissions" + , "apply only to part of the Program, that part may be used separately" + , "under those permissions, but the entire Program remains governed by" + , "this License without regard to the additional permissions." + , "" + , " When you convey a copy of a covered work, you may at your option" + , "remove any additional permissions from that copy, or from any part of" + , "it. (Additional permissions may be written to require their own" + , "removal in certain cases when you modify the work.) You may place" + , "additional permissions on material, added by you to a covered work," + , "for which you have or can give appropriate copyright permission." + , "" + , " Notwithstanding any other provision of this License, for material you" + , "add to a covered work, you may (if authorized by the copyright holders of" + , "that material) supplement the terms of this License with terms:" + , "" + , " a) Disclaiming warranty or limiting liability differently from the" + , " terms of sections 15 and 16 of this License; or" + , "" + , " b) Requiring preservation of specified reasonable legal notices or" + , " author attributions in that material or in the Appropriate Legal" + , " Notices displayed by works containing it; or" + , "" + , " c) Prohibiting misrepresentation of the origin of that material, or" + , " requiring that modified versions of such material be marked in" + , " reasonable ways as different from the original version; or" + , "" + , " d) Limiting the use for publicity purposes of names of licensors or" + , " authors of the material; or" + , "" + , " e) Declining to grant rights under trademark law for use of some" + , " trade names, trademarks, or service marks; or" + , "" + , " f) Requiring indemnification of licensors and authors of that" + , " material by anyone who conveys the material (or modified versions of" + , " it) with contractual assumptions of liability to the recipient, for" + , " any liability that these contractual assumptions directly impose on" + , " those licensors and authors." + , "" + , " All other non-permissive additional terms are considered \"further" + , "restrictions\" within the meaning of section 10. If the Program as you" + , "received it, or any part of it, contains a notice stating that it is" + , "governed by this License along with a term that is a further" + , "restriction, you may remove that term. If a license document contains" + , "a further restriction but permits relicensing or conveying under this" + , "License, you may add to a covered work material governed by the terms" + , "of that license document, provided that the further restriction does" + , "not survive such relicensing or conveying." + , "" + , " If you add terms to a covered work in accord with this section, you" + , "must place, in the relevant source files, a statement of the" + , "additional terms that apply to those files, or a notice indicating" + , "where to find the applicable terms." + , "" + , " Additional terms, permissive or non-permissive, may be stated in the" + , "form of a separately written license, or stated as exceptions;" + , "the above requirements apply either way." + , "" + , " 8. Termination." + , "" + , " You may not propagate or modify a covered work except as expressly" + , "provided under this License. Any attempt otherwise to propagate or" + , "modify it is void, and will automatically terminate your rights under" + , "this License (including any patent licenses granted under the third" + , "paragraph of section 11)." + , "" + , " However, if you cease all violation of this License, then your" + , "license from a particular copyright holder is reinstated (a)" + , "provisionally, unless and until the copyright holder explicitly and" + , "finally terminates your license, and (b) permanently, if the copyright" + , "holder fails to notify you of the violation by some reasonable means" + , "prior to 60 days after the cessation." + , "" + , " Moreover, your license from a particular copyright holder is" + , "reinstated permanently if the copyright holder notifies you of the" + , "violation by some reasonable means, this is the first time you have" + , "received notice of violation of this License (for any work) from that" + , "copyright holder, and you cure the violation prior to 30 days after" + , "your receipt of the notice." + , "" + , " Termination of your rights under this section does not terminate the" + , "licenses of parties who have received copies or rights from you under" + , "this License. If your rights have been terminated and not permanently" + , "reinstated, you do not qualify to receive new licenses for the same" + , "material under section 10." + , "" + , " 9. Acceptance Not Required for Having Copies." + , "" + , " You are not required to accept this License in order to receive or" + , "run a copy of the Program. Ancillary propagation of a covered work" + , "occurring solely as a consequence of using peer-to-peer transmission" + , "to receive a copy likewise does not require acceptance. However," + , "nothing other than this License grants you permission to propagate or" + , "modify any covered work. These actions infringe copyright if you do" + , "not accept this License. Therefore, by modifying or propagating a" + , "covered work, you indicate your acceptance of this License to do so." + , "" + , " 10. Automatic Licensing of Downstream Recipients." + , "" + , " Each time you convey a covered work, the recipient automatically" + , "receives a license from the original licensors, to run, modify and" + , "propagate that work, subject to this License. You are not responsible" + , "for enforcing compliance by third parties with this License." + , "" + , " An \"entity transaction\" is a transaction transferring control of an" + , "organization, or substantially all assets of one, or subdividing an" + , "organization, or merging organizations. If propagation of a covered" + , "work results from an entity transaction, each party to that" + , "transaction who receives a copy of the work also receives whatever" + , "licenses to the work the party's predecessor in interest had or could" + , "give under the previous paragraph, plus a right to possession of the" + , "Corresponding Source of the work from the predecessor in interest, if" + , "the predecessor has it or can get it with reasonable efforts." + , "" + , " You may not impose any further restrictions on the exercise of the" + , "rights granted or affirmed under this License. For example, you may" + , "not impose a license fee, royalty, or other charge for exercise of" + , "rights granted under this License, and you may not initiate litigation" + , "(including a cross-claim or counterclaim in a lawsuit) alleging that" + , "any patent claim is infringed by making, using, selling, offering for" + , "sale, or importing the Program or any portion of it." + , "" + , " 11. Patents." + , "" + , " A \"contributor\" is a copyright holder who authorizes use under this" + , "License of the Program or a work on which the Program is based. The" + , "work thus licensed is called the contributor's \"contributor version\"." + , "" + , " A contributor's \"essential patent claims\" are all patent claims" + , "owned or controlled by the contributor, whether already acquired or" + , "hereafter acquired, that would be infringed by some manner, permitted" + , "by this License, of making, using, or selling its contributor version," + , "but do not include claims that would be infringed only as a" + , "consequence of further modification of the contributor version. For" + , "purposes of this definition, \"control\" includes the right to grant" + , "patent sublicenses in a manner consistent with the requirements of" + , "this License." + , "" + , " Each contributor grants you a non-exclusive, worldwide, royalty-free" + , "patent license under the contributor's essential patent claims, to" + , "make, use, sell, offer for sale, import and otherwise run, modify and" + , "propagate the contents of its contributor version." + , "" + , " In the following three paragraphs, a \"patent license\" is any express" + , "agreement or commitment, however denominated, not to enforce a patent" + , "(such as an express permission to practice a patent or covenant not to" + , "sue for patent infringement). To \"grant\" such a patent license to a" + , "party means to make such an agreement or commitment not to enforce a" + , "patent against the party." + , "" + , " If you convey a covered work, knowingly relying on a patent license," + , "and the Corresponding Source of the work is not available for anyone" + , "to copy, free of charge and under the terms of this License, through a" + , "publicly available network server or other readily accessible means," + , "then you must either (1) cause the Corresponding Source to be so" + , "available, or (2) arrange to deprive yourself of the benefit of the" + , "patent license for this particular work, or (3) arrange, in a manner" + , "consistent with the requirements of this License, to extend the patent" + , "license to downstream recipients. \"Knowingly relying\" means you have" + , "actual knowledge that, but for the patent license, your conveying the" + , "covered work in a country, or your recipient's use of the covered work" + , "in a country, would infringe one or more identifiable patents in that" + , "country that you have reason to believe are valid." + , " " + , " If, pursuant to or in connection with a single transaction or" + , "arrangement, you convey, or propagate by procuring conveyance of, a" + , "covered work, and grant a patent license to some of the parties" + , "receiving the covered work authorizing them to use, propagate, modify" + , "or convey a specific copy of the covered work, then the patent license" + , "you grant is automatically extended to all recipients of the covered" + , "work and works based on it." + , "" + , " A patent license is \"discriminatory\" if it does not include within" + , "the scope of its coverage, prohibits the exercise of, or is" + , "conditioned on the non-exercise of one or more of the rights that are" + , "specifically granted under this License. You may not convey a covered" + , "work if you are a party to an arrangement with a third party that is" + , "in the business of distributing software, under which you make payment" + , "to the third party based on the extent of your activity of conveying" + , "the work, and under which the third party grants, to any of the" + , "parties who would receive the covered work from you, a discriminatory" + , "patent license (a) in connection with copies of the covered work" + , "conveyed by you (or copies made from those copies), or (b) primarily" + , "for and in connection with specific products or compilations that" + , "contain the covered work, unless you entered into that arrangement," + , "or that patent license was granted, prior to 28 March 2007." + , "" + , " Nothing in this License shall be construed as excluding or limiting" + , "any implied license or other defenses to infringement that may" + , "otherwise be available to you under applicable patent law." + , "" + , " 12. No Surrender of Others' Freedom." + , "" + , " If conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot convey a" + , "covered work so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you may" + , "not convey it at all. For example, if you agree to terms that obligate you" + , "to collect a royalty for further conveying from those to whom you convey" + , "the Program, the only way you could satisfy both those terms and this" + , "License would be to refrain entirely from conveying the Program." + , "" + , " 13. Use with the GNU Affero General Public License." + , "" + , " Notwithstanding any other provision of this License, you have" + , "permission to link or combine any covered work with a work licensed" + , "under version 3 of the GNU Affero General Public License into a single" + , "combined work, and to convey the resulting work. The terms of this" + , "License will continue to apply to the part which is the covered work," + , "but the special requirements of the GNU Affero General Public License," + , "section 13, concerning interaction through a network will apply to the" + , "combination as such." + , "" + , " 14. Revised Versions of this License." + , "" + , " The Free Software Foundation may publish revised and/or new versions of" + , "the GNU General Public License from time to time. Such new versions will" + , "be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Program specifies that a certain numbered version of the GNU General" + , "Public License \"or any later version\" applies to it, you have the" + , "option of following the terms and conditions either of that numbered" + , "version or of any later version published by the Free Software" + , "Foundation. If the Program does not specify a version number of the" + , "GNU General Public License, you may choose any version ever published" + , "by the Free Software Foundation." + , "" + , " If the Program specifies that a proxy can decide which future" + , "versions of the GNU General Public License can be used, that proxy's" + , "public statement of acceptance of a version permanently authorizes you" + , "to choose that version for the Program." + , "" + , " Later license versions may give you additional or different" + , "permissions. However, no additional obligations are imposed on any" + , "author or copyright holder as a result of your choosing to follow a" + , "later version." + , "" + , " 15. Disclaimer of Warranty." + , "" + , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" + , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" + , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" + , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," + , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" + , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" + , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. Limitation of Liability." + , "" + , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" + , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" + , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" + , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" + , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" + , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," + , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" + , "SUCH DAMAGES." + , "" + , " 17. Interpretation of Sections 15 and 16." + , "" + , " If the disclaimer of warranty and limitation of liability provided" + , "above cannot be given local legal effect according to their terms," + , "reviewing courts shall apply local law that most closely approximates" + , "an absolute waiver of all civil liability in connection with the" + , "Program, unless a warranty or assumption of liability accompanies a" + , "copy of the Program in return for a fee." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "state the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software: you can redistribute it and/or modify" + , " it under the terms of the GNU General Public License as published by" + , " the Free Software Foundation, either version 3 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License" + , " along with this program. If not, see ." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , " If the program does terminal interaction, make it output a short" + , "notice like this when it starts in an interactive mode:" + , "" + , " Copyright (C) " + , " This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, your program's commands" + , "might be different; for a GUI interface, you would use an \"about box\"." + , "" + , " You should also get your employer (if you work as a programmer) or school," + , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." + , "For more information on this, and how to apply and follow the GNU GPL, see" + , "." + , "" + , " The GNU General Public License does not permit incorporating your program" + , "into proprietary programs. If your program is a subroutine library, you" + , "may consider it more useful to permit linking proprietary applications with" + , "the library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License. But first, please read" + , "." + , "" + ] + +lgpl2 :: License +lgpl2 = unlines + [ " GNU LIBRARY GENERAL PUBLIC LICENSE" + , " Version 2, June 1991" + , "" + , " Copyright (C) 1991 Free Software Foundation, Inc." + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "[This is the first released version of the library GPL. It is" + , " numbered 2 because it goes with version 2 of the ordinary GPL.]" + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "Licenses are intended to guarantee your freedom to share and change" + , "free software--to make sure the software is free for all its users." + , "" + , " This license, the Library General Public License, applies to some" + , "specially designated Free Software Foundation software, and to any" + , "other libraries whose authors decide to use it. You can use it for" + , "your libraries, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "this service if you wish), that you receive source code or can get it" + , "if you want it, that you can change the software or use pieces of it" + , "in new free programs; and that you know you can do these things." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "anyone to deny you these rights or to ask you to surrender the rights." + , "These restrictions translate to certain responsibilities for you if" + , "you distribute copies of the library, or if you modify it." + , "" + , " For example, if you distribute copies of the library, whether gratis" + , "or for a fee, you must give the recipients all the rights that we gave" + , "you. You must make sure that they, too, receive or can get the source" + , "code. If you link a program with the library, you must provide" + , "complete object files to the recipients so that they can relink them" + , "with the library, after making changes to the library and recompiling" + , "it. And you must show them these terms so they know their rights." + , "" + , " Our method of protecting your rights has two steps: (1) copyright" + , "the library, and (2) offer you this license which gives you legal" + , "permission to copy, distribute and/or modify the library." + , "" + , " Also, for each distributor's protection, we want to make certain" + , "that everyone understands that there is no warranty for this free" + , "library. If the library is modified by someone else and passed on, we" + , "want its recipients to know that what they have is not the original" + , "version, so that any problems introduced by others will not reflect on" + , "the original authors' reputations." + , "" + , " Finally, any free program is threatened constantly by software" + , "patents. We wish to avoid the danger that companies distributing free" + , "software will individually obtain patent licenses, thus in effect" + , "transforming the program into proprietary software. To prevent this," + , "we have made it clear that any patent must be licensed for everyone's" + , "free use or not licensed at all." + , "" + , " Most GNU software, including some libraries, is covered by the ordinary" + , "GNU General Public License, which was designed for utility programs. This" + , "license, the GNU Library General Public License, applies to certain" + , "designated libraries. This license is quite different from the ordinary" + , "one; be sure to read it in full, and don't assume that anything in it is" + , "the same as in the ordinary license." + , "" + , " The reason we have a separate public license for some libraries is that" + , "they blur the distinction we usually make between modifying or adding to a" + , "program and simply using it. Linking a program with a library, without" + , "changing the library, is in some sense simply using the library, and is" + , "analogous to running a utility program or application program. However, in" + , "a textual and legal sense, the linked executable is a combined work, a" + , "derivative of the original library, and the ordinary General Public License" + , "treats it as such." + , "" + , " Because of this blurred distinction, using the ordinary General" + , "Public License for libraries did not effectively promote software" + , "sharing, because most developers did not use the libraries. We" + , "concluded that weaker conditions might promote sharing better." + , "" + , " However, unrestricted linking of non-free programs would deprive the" + , "users of those programs of all benefit from the free status of the" + , "libraries themselves. This Library General Public License is intended to" + , "permit developers of non-free programs to use free libraries, while" + , "preserving your freedom as a user of such programs to change the free" + , "libraries that are incorporated in them. (We have not seen how to achieve" + , "this as regards changes in header files, but we have achieved it as regards" + , "changes in the actual functions of the Library.) The hope is that this" + , "will lead to faster development of free libraries." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow. Pay close attention to the difference between a" + , "\"work based on the library\" and a \"work that uses the library\". The" + , "former contains code derived from the library, while the latter only" + , "works together with the library." + , "" + , " Note that it is possible for a library to be covered by the ordinary" + , "General Public License rather than by this special one." + , "" + , " GNU LIBRARY GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License Agreement applies to any software library which" + , "contains a notice placed by the copyright holder or other authorized" + , "party saying it may be distributed under the terms of this Library" + , "General Public License (also called \"this License\"). Each licensee is" + , "addressed as \"you\"." + , "" + , " A \"library\" means a collection of software functions and/or data" + , "prepared so as to be conveniently linked with application programs" + , "(which use some of those functions and data) to form executables." + , "" + , " The \"Library\", below, refers to any such software library or work" + , "which has been distributed under these terms. A \"work based on the" + , "Library\" means either the Library or any derivative work under" + , "copyright law: that is to say, a work containing the Library or a" + , "portion of it, either verbatim or with modifications and/or translated" + , "straightforwardly into another language. (Hereinafter, translation is" + , "included without limitation in the term \"modification\".)" + , "" + , " \"Source code\" for a work means the preferred form of the work for" + , "making modifications to it. For a library, complete source code means" + , "all the source code for all modules it contains, plus any associated" + , "interface definition files, plus the scripts used to control compilation" + , "and installation of the library." + , "" + , " Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running a program using the Library is not restricted, and output from" + , "such a program is covered only if its contents constitute a work based" + , "on the Library (independent of the use of the Library in a tool for" + , "writing it). Whether that is true depends on what the Library does" + , "and what the program that uses the Library does." + , " " + , " 1. You may copy and distribute verbatim copies of the Library's" + , "complete source code as you receive it, in any medium, provided that" + , "you conspicuously and appropriately publish on each copy an" + , "appropriate copyright notice and disclaimer of warranty; keep intact" + , "all the notices that refer to this License and to the absence of any" + , "warranty; and distribute a copy of this License along with the" + , "Library." + , "" + , " You may charge a fee for the physical act of transferring a copy," + , "and you may at your option offer warranty protection in exchange for a" + , "fee." + , "" + , " 2. You may modify your copy or copies of the Library or any portion" + , "of it, thus forming a work based on the Library, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) The modified work must itself be a software library." + , "" + , " b) You must cause the files modified to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " c) You must cause the whole of the work to be licensed at no" + , " charge to all third parties under the terms of this License." + , "" + , " d) If a facility in the modified Library refers to a function or a" + , " table of data to be supplied by an application program that uses" + , " the facility, other than as an argument passed when the facility" + , " is invoked, then you must make a good faith effort to ensure that," + , " in the event an application does not supply such function or" + , " table, the facility still operates, and performs whatever part of" + , " its purpose remains meaningful." + , "" + , " (For example, a function in a library to compute square roots has" + , " a purpose that is entirely well-defined independent of the" + , " application. Therefore, Subsection 2d requires that any" + , " application-supplied function or table used by this function must" + , " be optional: if the application does not supply it, the square" + , " root function must still compute square roots.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Library," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Library, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote" + , "it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Library." + , "" + , "In addition, mere aggregation of another work not based on the Library" + , "with the Library (or with a work based on the Library) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may opt to apply the terms of the ordinary GNU General Public" + , "License instead of this License to a given copy of the Library. To do" + , "this, you must alter all the notices that refer to this License, so" + , "that they refer to the ordinary GNU General Public License, version 2," + , "instead of to this License. (If a newer version than version 2 of the" + , "ordinary GNU General Public License has appeared, then you can specify" + , "that version instead if you wish.) Do not make any other change in" + , "these notices." + , "" + , " Once this change is made in a given copy, it is irreversible for" + , "that copy, so the ordinary GNU General Public License applies to all" + , "subsequent copies and derivative works made from that copy." + , "" + , " This option is useful when you wish to copy part of the code of" + , "the Library into a program that is not a library." + , "" + , " 4. You may copy and distribute the Library (or a portion or" + , "derivative of it, under Section 2) in object code or executable form" + , "under the terms of Sections 1 and 2 above provided that you accompany" + , "it with the complete corresponding machine-readable source code, which" + , "must be distributed under the terms of Sections 1 and 2 above on a" + , "medium customarily used for software interchange." + , "" + , " If distribution of object code is made by offering access to copy" + , "from a designated place, then offering equivalent access to copy the" + , "source code from the same place satisfies the requirement to" + , "distribute the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 5. A program that contains no derivative of any portion of the" + , "Library, but is designed to work with the Library by being compiled or" + , "linked with it, is called a \"work that uses the Library\". Such a" + , "work, in isolation, is not a derivative work of the Library, and" + , "therefore falls outside the scope of this License." + , "" + , " However, linking a \"work that uses the Library\" with the Library" + , "creates an executable that is a derivative of the Library (because it" + , "contains portions of the Library), rather than a \"work that uses the" + , "library\". The executable is therefore covered by this License." + , "Section 6 states terms for distribution of such executables." + , "" + , " When a \"work that uses the Library\" uses material from a header file" + , "that is part of the Library, the object code for the work may be a" + , "derivative work of the Library even though the source code is not." + , "Whether this is true is especially significant if the work can be" + , "linked without the Library, or if the work is itself a library. The" + , "threshold for this to be true is not precisely defined by law." + , "" + , " If such an object file uses only numerical parameters, data" + , "structure layouts and accessors, and small macros and small inline" + , "functions (ten lines or less in length), then the use of the object" + , "file is unrestricted, regardless of whether it is legally a derivative" + , "work. (Executables containing this object code plus portions of the" + , "Library will still fall under Section 6.)" + , "" + , " Otherwise, if the work is a derivative of the Library, you may" + , "distribute the object code for the work under the terms of Section 6." + , "Any executables containing that work also fall under Section 6," + , "whether or not they are linked directly with the Library itself." + , "" + , " 6. As an exception to the Sections above, you may also compile or" + , "link a \"work that uses the Library\" with the Library to produce a" + , "work containing portions of the Library, and distribute that work" + , "under terms of your choice, provided that the terms permit" + , "modification of the work for the customer's own use and reverse" + , "engineering for debugging such modifications." + , "" + , " You must give prominent notice with each copy of the work that the" + , "Library is used in it and that the Library and its use are covered by" + , "this License. You must supply a copy of this License. If the work" + , "during execution displays copyright notices, you must include the" + , "copyright notice for the Library among them, as well as a reference" + , "directing the user to the copy of this License. Also, you must do one" + , "of these things:" + , "" + , " a) Accompany the work with the complete corresponding" + , " machine-readable source code for the Library including whatever" + , " changes were used in the work (which must be distributed under" + , " Sections 1 and 2 above); and, if the work is an executable linked" + , " with the Library, with the complete machine-readable \"work that" + , " uses the Library\", as object code and/or source code, so that the" + , " user can modify the Library and then relink to produce a modified" + , " executable containing the modified Library. (It is understood" + , " that the user who changes the contents of definitions files in the" + , " Library will not necessarily be able to recompile the application" + , " to use the modified definitions.)" + , "" + , " b) Accompany the work with a written offer, valid for at" + , " least three years, to give the same user the materials" + , " specified in Subsection 6a, above, for a charge no more" + , " than the cost of performing this distribution." + , "" + , " c) If distribution of the work is made by offering access to copy" + , " from a designated place, offer equivalent access to copy the above" + , " specified materials from the same place." + , "" + , " d) Verify that the user has already received a copy of these" + , " materials or that you have already sent this user a copy." + , "" + , " For an executable, the required form of the \"work that uses the" + , "Library\" must include any data and utility programs needed for" + , "reproducing the executable from it. However, as a special exception," + , "the source code distributed need not include anything that is normally" + , "distributed (in either source or binary form) with the major" + , "components (compiler, kernel, and so on) of the operating system on" + , "which the executable runs, unless that component itself accompanies" + , "the executable." + , "" + , " It may happen that this requirement contradicts the license" + , "restrictions of other proprietary libraries that do not normally" + , "accompany the operating system. Such a contradiction means you cannot" + , "use both them and the Library together in an executable that you" + , "distribute." + , "" + , " 7. You may place library facilities that are a work based on the" + , "Library side-by-side in a single library together with other library" + , "facilities not covered by this License, and distribute such a combined" + , "library, provided that the separate distribution of the work based on" + , "the Library and of the other library facilities is otherwise" + , "permitted, and provided that you do these two things:" + , "" + , " a) Accompany the combined library with a copy of the same work" + , " based on the Library, uncombined with any other library" + , " facilities. This must be distributed under the terms of the" + , " Sections above." + , "" + , " b) Give prominent notice with the combined library of the fact" + , " that part of it is a work based on the Library, and explaining" + , " where to find the accompanying uncombined form of the same work." + , "" + , " 8. You may not copy, modify, sublicense, link with, or distribute" + , "the Library except as expressly provided under this License. Any" + , "attempt otherwise to copy, modify, sublicense, link with, or" + , "distribute the Library is void, and will automatically terminate your" + , "rights under this License. However, parties who have received copies," + , "or rights, from you under this License will not have their licenses" + , "terminated so long as such parties remain in full compliance." + , "" + , " 9. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Library or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Library (or any work based on the" + , "Library), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Library or works based on it." + , "" + , " 10. Each time you redistribute the Library (or any work based on the" + , "Library), the recipient automatically receives a license from the" + , "original licensor to copy, distribute, link with or modify the Library" + , "subject to these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties to" + , "this License." + , "" + , " 11. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Library at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Library by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Library." + , "" + , "If any portion of this section is held invalid or unenforceable under any" + , "particular circumstance, the balance of the section is intended to apply," + , "and the section as a whole is intended to apply in other circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 12. If the distribution and/or use of the Library is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Library under this License may add" + , "an explicit geographical distribution limitation excluding those countries," + , "so that distribution is permitted only in or among countries not thus" + , "excluded. In such case, this License incorporates the limitation as if" + , "written in the body of this License." + , "" + , " 13. The Free Software Foundation may publish revised and/or new" + , "versions of the Library General Public License from time to time." + , "Such new versions will be similar in spirit to the present version," + , "but may differ in detail to address new problems or concerns." + , "" + , "Each version is given a distinguishing version number. If the Library" + , "specifies a version number of this License which applies to it and" + , "\"any later version\", you have the option of following the terms and" + , "conditions either of that version or of any later version published by" + , "the Free Software Foundation. If the Library does not specify a" + , "license version number, you may choose any version ever published by" + , "the Free Software Foundation." + , "" + , " 14. If you wish to incorporate parts of the Library into other free" + , "programs whose distribution conditions are incompatible with these," + , "write to the author to ask for permission. For software which is" + , "copyrighted by the Free Software Foundation, write to the Free" + , "Software Foundation; we sometimes make exceptions for this. Our" + , "decision will be guided by the two goals of preserving the free status" + , "of all derivatives of our free software and of promoting the sharing" + , "and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO" + , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW." + , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR" + , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY" + , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE" + , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE" + , "LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME" + , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN" + , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY" + , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU" + , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR" + , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE" + , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING" + , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A" + , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF" + , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH" + , "DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Libraries" + , "" + , " If you develop a new library, and you want it to be of the greatest" + , "possible use to the public, we recommend making it free software that" + , "everyone can redistribute and change. You can do so by permitting" + , "redistribution under these terms (or, alternatively, under the terms of the" + , "ordinary General Public License)." + , "" + , " To apply these terms, attach the following notices to the library. It is" + , "safest to attach them to the start of each source file to most effectively" + , "convey the exclusion of warranty; and each file should have at least the" + , "\"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This library is free software; you can redistribute it and/or" + , " modify it under the terms of the GNU Library General Public" + , " License as published by the Free Software Foundation; either" + , " version 2 of the License, or (at your option) any later version." + , "" + , " This library is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" + , " Library General Public License for more details." + , "" + , " You should have received a copy of the GNU Library General Public" + , " License along with this library; if not, write to the Free" + , " Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the library, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the" + , " library `Frob' (a library for tweaking knobs) written by James Random Hacker." + , "" + , " , 1 April 1990" + , " Ty Coon, President of Vice" + , "" + , "That's all there is to it!" + ] + +lgpl3 :: License +lgpl3 = unlines + [ " GNU LESSER GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "" + , " This version of the GNU Lesser General Public License incorporates" + , "the terms and conditions of version 3 of the GNU General Public" + , "License, supplemented by the additional permissions listed below." + , "" + , " 0. Additional Definitions. " + , "" + , " As used herein, \"this License\" refers to version 3 of the GNU Lesser" + , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU" + , "General Public License." + , "" + , " \"The Library\" refers to a covered work governed by this License," + , "other than an Application or a Combined Work as defined below." + , "" + , " An \"Application\" is any work that makes use of an interface provided" + , "by the Library, but which is not otherwise based on the Library." + , "Defining a subclass of a class defined by the Library is deemed a mode" + , "of using an interface provided by the Library." + , "" + , " A \"Combined Work\" is a work produced by combining or linking an" + , "Application with the Library. The particular version of the Library" + , "with which the Combined Work was made is also called the \"Linked" + , "Version\"." + , "" + , " The \"Minimal Corresponding Source\" for a Combined Work means the" + , "Corresponding Source for the Combined Work, excluding any source code" + , "for portions of the Combined Work that, considered in isolation, are" + , "based on the Application, and not on the Linked Version." + , "" + , " The \"Corresponding Application Code\" for a Combined Work means the" + , "object code and/or source code for the Application, including any data" + , "and utility programs needed for reproducing the Combined Work from the" + , "Application, but excluding the System Libraries of the Combined Work." + , "" + , " 1. Exception to Section 3 of the GNU GPL." + , "" + , " You may convey a covered work under sections 3 and 4 of this License" + , "without being bound by section 3 of the GNU GPL." + , "" + , " 2. Conveying Modified Versions." + , "" + , " If you modify a copy of the Library, and, in your modifications, a" + , "facility refers to a function or data to be supplied by an Application" + , "that uses the facility (other than as an argument passed when the" + , "facility is invoked), then you may convey a copy of the modified" + , "version:" + , "" + , " a) under this License, provided that you make a good faith effort to" + , " ensure that, in the event an Application does not supply the" + , " function or data, the facility still operates, and performs" + , " whatever part of its purpose remains meaningful, or" + , "" + , " b) under the GNU GPL, with none of the additional permissions of" + , " this License applicable to that copy." + , "" + , " 3. Object Code Incorporating Material from Library Header Files." + , "" + , " The object code form of an Application may incorporate material from" + , "a header file that is part of the Library. You may convey such object" + , "code under terms of your choice, provided that, if the incorporated" + , "material is not limited to numerical parameters, data structure" + , "layouts and accessors, or small macros, inline functions and templates" + , "(ten or fewer lines in length), you do both of the following:" + , "" + , " a) Give prominent notice with each copy of the object code that the" + , " Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the object code with a copy of the GNU GPL and this license" + , " document." + , "" + , " 4. Combined Works." + , "" + , " You may convey a Combined Work under terms of your choice that," + , "taken together, effectively do not restrict modification of the" + , "portions of the Library contained in the Combined Work and reverse" + , "engineering for debugging such modifications, if you also do each of" + , "the following:" + , "" + , " a) Give prominent notice with each copy of the Combined Work that" + , " the Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the Combined Work with a copy of the GNU GPL and this license" + , " document." + , "" + , " c) For a Combined Work that displays copyright notices during" + , " execution, include the copyright notice for the Library among" + , " these notices, as well as a reference directing the user to the" + , " copies of the GNU GPL and this license document." + , "" + , " d) Do one of the following:" + , "" + , " 0) Convey the Minimal Corresponding Source under the terms of this" + , " License, and the Corresponding Application Code in a form" + , " suitable for, and under terms that permit, the user to" + , " recombine or relink the Application with a modified version of" + , " the Linked Version to produce a modified Combined Work, in the" + , " manner specified by section 6 of the GNU GPL for conveying" + , " Corresponding Source." + , "" + , " 1) Use a suitable shared library mechanism for linking with the" + , " Library. A suitable mechanism is one that (a) uses at run time" + , " a copy of the Library already present on the user's computer" + , " system, and (b) will operate properly with a modified version" + , " of the Library that is interface-compatible with the Linked" + , " Version. " + , "" + , " e) Provide Installation Information, but only if you would otherwise" + , " be required to provide such information under section 6 of the" + , " GNU GPL, and only to the extent that such information is" + , " necessary to install and execute a modified version of the" + , " Combined Work produced by recombining or relinking the" + , " Application with a modified version of the Linked Version. (If" + , " you use option 4d0, the Installation Information must accompany" + , " the Minimal Corresponding Source and Corresponding Application" + , " Code. If you use option 4d1, you must provide the Installation" + , " Information in the manner specified by section 6 of the GNU GPL" + , " for conveying Corresponding Source.)" + , "" + , " 5. Combined Libraries." + , "" + , " You may place library facilities that are a work based on the" + , "Library side by side in a single library together with other library" + , "facilities that are not Applications and are not covered by this" + , "License, and convey such a combined library under terms of your" + , "choice, if you do both of the following:" + , "" + , " a) Accompany the combined library with a copy of the same work based" + , " on the Library, uncombined with any other library facilities," + , " conveyed under the terms of this License." + , "" + , " b) Give prominent notice with the combined library that part of it" + , " is a work based on the Library, and explaining where to find the" + , " accompanying uncombined form of the same work." + , "" + , " 6. Revised Versions of the GNU Lesser General Public License." + , "" + , " The Free Software Foundation may publish revised and/or new versions" + , "of the GNU Lesser General Public License from time to time. Such new" + , "versions will be similar in spirit to the present version, but may" + , "differ in detail to address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Library as you received it specifies that a certain numbered version" + , "of the GNU Lesser General Public License \"or any later version\"" + , "applies to it, you have the option of following the terms and" + , "conditions either of that published version or of any later version" + , "published by the Free Software Foundation. If the Library as you" + , "received it does not specify a version number of the GNU Lesser" + , "General Public License, you may choose any version of the GNU Lesser" + , "General Public License ever published by the Free Software Foundation." + , "" + , " If the Library as you received it specifies that a proxy can decide" + , "whether future versions of the GNU Lesser General Public License shall" + , "apply, that proxy's public statement of acceptance of any version is" + , "permanent authorization for you to choose that version for the" + , "Library." + ] + +apache20 :: License +apache20 = unlines + [ "" + , " Apache License" + , " Version 2.0, January 2004" + , " http://www.apache.org/licenses/" + , "" + , " TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION" + , "" + , " 1. Definitions." + , "" + , " \"License\" shall mean the terms and conditions for use, reproduction," + , " and distribution as defined by Sections 1 through 9 of this document." + , "" + , " \"Licensor\" shall mean the copyright owner or entity authorized by" + , " the copyright owner that is granting the License." + , "" + , " \"Legal Entity\" shall mean the union of the acting entity and all" + , " other entities that control, are controlled by, or are under common" + , " control with that entity. For the purposes of this definition," + , " \"control\" means (i) the power, direct or indirect, to cause the" + , " direction or management of such entity, whether by contract or" + , " otherwise, or (ii) ownership of fifty percent (50%) or more of the" + , " outstanding shares, or (iii) beneficial ownership of such entity." + , "" + , " \"You\" (or \"Your\") shall mean an individual or Legal Entity" + , " exercising permissions granted by this License." + , "" + , " \"Source\" form shall mean the preferred form for making modifications," + , " including but not limited to software source code, documentation" + , " source, and configuration files." + , "" + , " \"Object\" form shall mean any form resulting from mechanical" + , " transformation or translation of a Source form, including but" + , " not limited to compiled object code, generated documentation," + , " and conversions to other media types." + , "" + , " \"Work\" shall mean the work of authorship, whether in Source or" + , " Object form, made available under the License, as indicated by a" + , " copyright notice that is included in or attached to the work" + , " (an example is provided in the Appendix below)." + , "" + , " \"Derivative Works\" shall mean any work, whether in Source or Object" + , " form, that is based on (or derived from) the Work and for which the" + , " editorial revisions, annotations, elaborations, or other modifications" + , " represent, as a whole, an original work of authorship. For the purposes" + , " of this License, Derivative Works shall not include works that remain" + , " separable from, or merely link (or bind by name) to the interfaces of," + , " the Work and Derivative Works thereof." + , "" + , " \"Contribution\" shall mean any work of authorship, including" + , " the original version of the Work and any modifications or additions" + , " to that Work or Derivative Works thereof, that is intentionally" + , " submitted to Licensor for inclusion in the Work by the copyright owner" + , " or by an individual or Legal Entity authorized to submit on behalf of" + , " the copyright owner. For the purposes of this definition, \"submitted\"" + , " means any form of electronic, verbal, or written communication sent" + , " to the Licensor or its representatives, including but not limited to" + , " communication on electronic mailing lists, source code control systems," + , " and issue tracking systems that are managed by, or on behalf of, the" + , " Licensor for the purpose of discussing and improving the Work, but" + , " excluding communication that is conspicuously marked or otherwise" + , " designated in writing by the copyright owner as \"Not a Contribution.\"" + , "" + , " \"Contributor\" shall mean Licensor and any individual or Legal Entity" + , " on behalf of whom a Contribution has been received by Licensor and" + , " subsequently incorporated within the Work." + , "" + , " 2. Grant of Copyright License. Subject to the terms and conditions of" + , " this License, each Contributor hereby grants to You a perpetual," + , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable" + , " copyright license to reproduce, prepare Derivative Works of," + , " publicly display, publicly perform, sublicense, and distribute the" + , " Work and such Derivative Works in Source or Object form." + , "" + , " 3. Grant of Patent License. Subject to the terms and conditions of" + , " this License, each Contributor hereby grants to You a perpetual," + , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable" + , " (except as stated in this section) patent license to make, have made," + , " use, offer to sell, sell, import, and otherwise transfer the Work," + , " where such license applies only to those patent claims licensable" + , " by such Contributor that are necessarily infringed by their" + , " Contribution(s) alone or by combination of their Contribution(s)" + , " with the Work to which such Contribution(s) was submitted. If You" + , " institute patent litigation against any entity (including a" + , " cross-claim or counterclaim in a lawsuit) alleging that the Work" + , " or a Contribution incorporated within the Work constitutes direct" + , " or contributory patent infringement, then any patent licenses" + , " granted to You under this License for that Work shall terminate" + , " as of the date such litigation is filed." + , "" + , " 4. Redistribution. You may reproduce and distribute copies of the" + , " Work or Derivative Works thereof in any medium, with or without" + , " modifications, and in Source or Object form, provided that You" + , " meet the following conditions:" + , "" + , " (a) You must give any other recipients of the Work or" + , " Derivative Works a copy of this License; and" + , "" + , " (b) You must cause any modified files to carry prominent notices" + , " stating that You changed the files; and" + , "" + , " (c) You must retain, in the Source form of any Derivative Works" + , " that You distribute, all copyright, patent, trademark, and" + , " attribution notices from the Source form of the Work," + , " excluding those notices that do not pertain to any part of" + , " the Derivative Works; and" + , "" + , " (d) If the Work includes a \"NOTICE\" text file as part of its" + , " distribution, then any Derivative Works that You distribute must" + , " include a readable copy of the attribution notices contained" + , " within such NOTICE file, excluding those notices that do not" + , " pertain to any part of the Derivative Works, in at least one" + , " of the following places: within a NOTICE text file distributed" + , " as part of the Derivative Works; within the Source form or" + , " documentation, if provided along with the Derivative Works; or," + , " within a display generated by the Derivative Works, if and" + , " wherever such third-party notices normally appear. The contents" + , " of the NOTICE file are for informational purposes only and" + , " do not modify the License. You may add Your own attribution" + , " notices within Derivative Works that You distribute, alongside" + , " or as an addendum to the NOTICE text from the Work, provided" + , " that such additional attribution notices cannot be construed" + , " as modifying the License." + , "" + , " You may add Your own copyright statement to Your modifications and" + , " may provide additional or different license terms and conditions" + , " for use, reproduction, or distribution of Your modifications, or" + , " for any such Derivative Works as a whole, provided Your use," + , " reproduction, and distribution of the Work otherwise complies with" + , " the conditions stated in this License." + , "" + , " 5. Submission of Contributions. Unless You explicitly state otherwise," + , " any Contribution intentionally submitted for inclusion in the Work" + , " by You to the Licensor shall be under the terms and conditions of" + , " this License, without any additional terms or conditions." + , " Notwithstanding the above, nothing herein shall supersede or modify" + , " the terms of any separate license agreement you may have executed" + , " with Licensor regarding such Contributions." + , "" + , " 6. Trademarks. This License does not grant permission to use the trade" + , " names, trademarks, service marks, or product names of the Licensor," + , " except as required for reasonable and customary use in describing the" + , " origin of the Work and reproducing the content of the NOTICE file." + , "" + , " 7. Disclaimer of Warranty. Unless required by applicable law or" + , " agreed to in writing, Licensor provides the Work (and each" + , " Contributor provides its Contributions) on an \"AS IS\" BASIS," + , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or" + , " implied, including, without limitation, any warranties or conditions" + , " of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A" + , " PARTICULAR PURPOSE. You are solely responsible for determining the" + , " appropriateness of using or redistributing the Work and assume any" + , " risks associated with Your exercise of permissions under this License." + , "" + , " 8. Limitation of Liability. In no event and under no legal theory," + , " whether in tort (including negligence), contract, or otherwise," + , " unless required by applicable law (such as deliberate and grossly" + , " negligent acts) or agreed to in writing, shall any Contributor be" + , " liable to You for damages, including any direct, indirect, special," + , " incidental, or consequential damages of any character arising as a" + , " result of this License or out of the use or inability to use the" + , " Work (including but not limited to damages for loss of goodwill," + , " work stoppage, computer failure or malfunction, or any and all" + , " other commercial damages or losses), even if such Contributor" + , " has been advised of the possibility of such damages." + , "" + , " 9. Accepting Warranty or Additional Liability. While redistributing" + , " the Work or Derivative Works thereof, You may choose to offer," + , " and charge a fee for, acceptance of support, warranty, indemnity," + , " or other liability obligations and/or rights consistent with this" + , " License. However, in accepting such obligations, You may act only" + , " on Your own behalf and on Your sole responsibility, not on behalf" + , " of any other Contributor, and only if You agree to indemnify," + , " defend, and hold each Contributor harmless for any liability" + , " incurred by, or claims asserted against, such Contributor by reason" + , " of your accepting any such warranty or additional liability." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " APPENDIX: How to apply the Apache License to your work." + , "" + , " To apply the Apache License to your work, attach the following" + , " boilerplate notice, with the fields enclosed by brackets \"[]\"" + , " replaced with your own identifying information. (Don't include" + , " the brackets!) The text should be enclosed in the appropriate" + , " comment syntax for the file format. We also recommend that a" + , " file or class name and description of purpose be included on the" + , " same \"printed page\" as the copyright notice for easier" + , " identification within third-party archives." + , "" + , " Copyright [yyyy] [name of copyright owner]" + , "" + , " Licensed under the Apache License, Version 2.0 (the \"License\");" + , " you may not use this file except in compliance with the License." + , " You may obtain a copy of the License at" + , "" + , " http://www.apache.org/licenses/LICENSE-2.0" + , "" + , " Unless required by applicable law or agreed to in writing, software" + , " distributed under the License is distributed on an \"AS IS\" BASIS," + , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied." + , " See the License for the specific language governing permissions and" + , " limitations under the License." + ] diff --git a/IdeSession/Query.hs b/IdeSession/Query.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Query.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} +-- | Session queries +-- +-- We have to be very careful in the types in this module. We should not be +-- using internal types (with explicit sharing or types such as StrictMap), +-- except as part of abstract XShared types. +module IdeSession.Query ( + -- * Types + Query + , ManagedFiles(..) + , InvalidSessionStateQueries(..) + -- * Queries that rely on the static part of the state only + , getSessionConfig + , getSourcesDir + , getDataDir + , getDistDir + , getSourceModule + , getDataFile + , getAllDataFiles + , getCabalMacros + -- * Queries that do not rely on computed state + , getCodeGeneration + , getEnv + , getArgs + , getGhcServer + , getGhcVersion + , getManagedFiles + , getBuildExeStatus + , getBuildDocStatus + , getBuildLicensesStatus + , getBreakInfo + -- * Queries that rely on computed state + , getSourceErrors + , getLoadedModules + , getFileMap + , getSpanInfo + , getExpTypes + , getImports + , getAutocompletion + , getPkgDeps + , getUseSites + , getDotCabal + -- * Debugging (internal use only) + , dumpIdInfo + , dumpAutocompletion + , dumpFileMap + ) where + +import Prelude hiding (mod, span) +import Control.Exception (Exception, throwIO) +import Control.Monad (forM_) +import Data.Accessor ((^.), (^:), getVal) +import Data.List (isInfixOf, sortBy) +import Data.Maybe (listToMaybe, maybeToList) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.Version (Version) +import System.Exit (ExitCode) +import System.FilePath (()) +import qualified Data.ByteString.Char8 as BSSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as Text (pack, unpack) +import qualified System.FilePath.Find as Find + +import IdeSession.Cabal +import IdeSession.Config +import IdeSession.GHC.API +import IdeSession.RPC.Client (ExternalException(..)) +import IdeSession.State +import IdeSession.Strict.Container +import IdeSession.Types.Public +import IdeSession.Types.Translation +import IdeSession.Util.BlockingOps +import qualified IdeSession.Strict.IntMap as StrictIntMap +import qualified IdeSession.Strict.IntervalMap as StrictIntervalMap +import qualified IdeSession.Strict.List as StrictList +import qualified IdeSession.Strict.Map as StrictMap +import qualified IdeSession.Strict.Maybe as StrictMaybe +import qualified IdeSession.Strict.Trie as StrictTrie +import qualified IdeSession.Types.Private as Private + +{------------------------------------------------------------------------------ + Types +------------------------------------------------------------------------------} + +-- | The type of queries in a given session state. +-- +-- Queries are in IO because they depend on the current state of the session +-- but they promise not to alter the session state (at least not in any visible +-- way; they might update caches, etc.). +-- +type Query a = IdeSession -> IO a + +-- | The collection of source and data files submitted by the user. +data ManagedFiles = ManagedFiles + { sourceFiles :: [FilePath] + , dataFiles :: [FilePath] + } + deriving Show + +{------------------------------------------------------------------------------ + Queries that rely on the static part of the state only +------------------------------------------------------------------------------} + +-- | Recover the fixed config the session was initialized with. +getSessionConfig :: Query SessionConfig +getSessionConfig = staticQuery $ return . ideConfig + +-- | Obtain the source files directory for this session. +getSourcesDir :: Query FilePath +getSourcesDir = staticQuery $ return . ideSessionSourceDir . ideSessionDir + +-- | Obtain the data files directory for this session. +getDataDir :: Query FilePath +getDataDir = staticQuery $ return . ideSessionDataDir . ideSessionDir + +-- | Obtain the directory prefix for results of Cabal invocations. +-- Executables compiled in this session end up in a subdirectory @build@, +-- haddocks in @doc@, concatenated licenses in file @licenses@, etc. +getDistDir :: Query FilePath +getDistDir = staticQuery $ return . ideSessionDistDir . ideSessionDir + +-- | Read the current value of one of the source modules. +getSourceModule :: FilePath -> Query BSL.ByteString +getSourceModule path = staticQuery $ \IdeStaticInfo{ideSessionDir} -> + BSL.readFile $ ideSessionSourceDir ideSessionDir path + +-- | Read the current value of one of the data files. +getDataFile :: FilePath -> Query BSL.ByteString +getDataFile path = staticQuery $ \IdeStaticInfo{ideSessionDir} -> + BSL.readFile $ ideSessionDataDir ideSessionDir path + +-- | Get the list of all data files currently available to the session: +-- both the files copied via an update and files created by user code. +getAllDataFiles :: Query [FilePath] +getAllDataFiles = staticQuery $ \IdeStaticInfo{ideSessionDir} -> + Find.find Find.always + (Find.fileType Find.==? Find.RegularFile) + (ideSessionDataDir ideSessionDir) + +getCabalMacros :: Query BSL.ByteString +getCabalMacros = staticQuery $ \IdeStaticInfo{ideSessionDir} -> + BSL.readFile $ cabalMacrosLocation (ideSessionDistDir ideSessionDir) + +{------------------------------------------------------------------------------ + Queries that do not rely on computed state +------------------------------------------------------------------------------} + +-- | Is code generation currently enabled? +getCodeGeneration :: Query Bool +getCodeGeneration = simpleQuery $ getVal ideGenerateCode + +-- | Get all current environment overrides +getEnv :: Query [(String, Maybe String)] +getEnv = simpleQuery $ getVal ideEnv + +-- | Get all current snippet args +getArgs :: Query [String] +getArgs = simpleQuery $ getVal ideArgs + +-- | Get the RPC server used by the session. +getGhcServer :: Query GhcServer +getGhcServer = simpleQuery $ getVal ideGhcServer + +-- | Which GHC version is `ide-backend-server` using? +getGhcVersion :: Query GhcVersion +getGhcVersion = simpleQuery $ getVal ideGhcVersion + +-- | Get the collection of files submitted by the user and not deleted yet. +-- The module names are those supplied by the user as the first +-- arguments of the @updateSourceFile@ and @updateSourceFileFromFile@ calls, +-- as opposed to the compiler internal @module ... end@ module names. +-- Usually the two names are equal, but they needn't be. +getManagedFiles :: Query ManagedFiles +getManagedFiles = simpleQuery $ translate . getVal ideManagedFiles + where + translate :: ManagedFilesInternal -> ManagedFiles + translate files = ManagedFiles { + sourceFiles = map fst $ _managedSource files + , dataFiles = map fst $ _managedData files + } + +-- | Get exit status of the last invocation of 'buildExe', if any. +getBuildExeStatus :: Query (Maybe ExitCode) +getBuildExeStatus = simpleQuery $ getVal ideBuildExeStatus + +-- | Get exit status of the last invocation of 'buildDoc', if any. +getBuildDocStatus :: Query (Maybe ExitCode) +getBuildDocStatus = simpleQuery $ getVal ideBuildDocStatus + +-- | Get exit status of the last invocation of 'buildLicenses', if any. +getBuildLicensesStatus :: Query (Maybe ExitCode) +getBuildLicensesStatus = simpleQuery $ getVal ideBuildLicensesStatus + +-- | Get information about the last breakpoint that we hit +-- +-- Returns Nothing if we are not currently stopped on a breakpoint. +getBreakInfo :: Query (Maybe BreakInfo) +getBreakInfo = simpleQuery $ toLazyMaybe . getVal ideBreakInfo + +{------------------------------------------------------------------------------ + Queries that rely on computed state +------------------------------------------------------------------------------} + +-- | Get any compilation errors or warnings in the current state of the +-- session, meaning errors that GHC reports for the current state of all the +-- source modules. +-- +-- Note that in the initial implementation this will only return warnings from +-- the modules that changed in the last update, the intended semantics is that +-- morally it be a pure function of the current state of the files, and so it +-- would return all warnings (as if you did clean and rebuild each time). +-- +-- getSourceErrors does internal normalization. This simplifies the life of the +-- client and anyway there shouldn't be that many source errors that it really +-- makes a big difference. +getSourceErrors :: Query [SourceError] +getSourceErrors = computedQuery $ \Computed{..} -> + toLazyList $ StrictList.map (removeExplicitSharing computedCache) computedErrors + +-- | Get the list of correctly compiled modules, as reported by the compiler +getLoadedModules :: Query [ModuleName] +getLoadedModules = computedQuery $ \Computed{..} -> + toLazyList $ computedLoadedModules + +-- | Get the mapping from filenames to modules (as computed by GHC) +getFileMap :: Query (FilePath -> Maybe ModuleId) +getFileMap = computedQuery $ \Computed{..} path -> + fmap (removeExplicitSharing computedCache) $ + StrictMap.lookup path computedFileMap + +-- | Get information about an identifier at a specific location +getSpanInfo :: Query (ModuleName -> SourceSpan -> [(SourceSpan, SpanInfo)]) +getSpanInfo = computedQuery $ \computed@Computed{..} mod span -> + let aux (a, b) = ( removeExplicitSharing computedCache a + , removeExplicitSharing computedCache b + ) + in map aux . maybeToList $ internalGetSpanInfo computed mod span + +internalGetSpanInfo :: Computed -> ModuleName -> SourceSpan + -> Maybe (Private.SourceSpan, Private.SpanInfo) +internalGetSpanInfo Computed{..} mod span = case (mSpan, mIdMap) of + (Just span', Just (Private.IdMap idMap)) -> + let doms = Private.dominators span' idMap + in listToMaybe (prioritize doms) + _ -> Nothing + where + mSpan = introduceExplicitSharing computedCache span + mIdMap = StrictMap.lookup mod computedSpanInfo + + prioritize :: [(Private.SourceSpan, Private.SpanInfo)] + -> [(Private.SourceSpan, Private.SpanInfo)] + prioritize = sortBy $ \(_, a) (_, b) -> + case (a, b) of + (Private.SpanQQ _, Private.SpanId _) -> LT + (Private.SpanInSplice _, Private.SpanId _) -> LT + (Private.SpanId _, Private.SpanQQ _) -> GT + (Private.SpanId _, Private.SpanInSplice _) -> GT + (_, _) -> EQ + +-- | Get information the type of a subexpressions and the subexpressions +-- around it +getExpTypes :: Query (ModuleName -> SourceSpan -> [(SourceSpan, Text)]) +getExpTypes = computedQuery $ \Computed{..} mod span -> + let mSpan = introduceExplicitSharing computedCache span + mExpMap = StrictMap.lookup mod computedExpTypes + in case (mSpan, mExpMap) of + (Just span', Just (Private.ExpMap expMap)) -> + let aux (a, b) = ( removeExplicitSharing computedCache a + , b + ) + doms = map aux $ Private.dominators span' expMap + in doms + _ -> + [] + +-- | Get import information +-- +-- This information is available even for modules with parse/type errors +getImports :: Query (ModuleName -> Maybe [Import]) +getImports = computedQuery $ \Computed{..} mod -> + fmap (toLazyList . StrictList.map (removeExplicitSharing computedCache)) $ + StrictMap.lookup mod computedImports + +-- | Autocompletion +-- +-- Use 'idInfoQN' to translate these 'IdInfo's into qualified names, taking +-- into account the module imports. +getAutocompletion :: Query (ModuleName -> String -> [IdInfo]) +getAutocompletion = computedQuery $ \Computed{..} -> + autocomplete computedCache computedAutoMap + where + autocomplete :: Private.ExplicitSharingCache + -> Strict (Map ModuleName) (Strict Trie (Strict [] (XShared IdInfo))) + -> ModuleName -> String + -> [IdInfo] + autocomplete cache mapOfTries modName name = + let name' = BSSC.pack name + n = last (BSSC.split '.' name') + in filter (\idInfo -> name `isInfixOf` idInfoQN idInfo) + $ concatMap (toLazyList . StrictList.map (removeExplicitSharing cache)) + . StrictTrie.elems + . StrictTrie.submap n + $ StrictMap.findWithDefault StrictTrie.empty modName mapOfTries + +-- | (Transitive) package dependencies +-- +-- These are only available for modules that got compiled successfully. +getPkgDeps :: Query (ModuleName -> Maybe [PackageId]) +getPkgDeps = computedQuery $ \Computed{..} mod -> + fmap (toLazyList . StrictList.map (removeExplicitSharing computedCache)) $ + StrictMap.lookup mod computedPkgDeps + +-- | Use sites +-- +-- Use sites are only reported in modules that get compiled successfully. +getUseSites :: Query (ModuleName -> SourceSpan -> [SourceSpan]) +getUseSites = computedQuery $ \computed@Computed{..} mod span -> + maybeListToList $ do + (_, spanId) <- internalGetSpanInfo computed mod span + Private.IdInfo{..} <- case spanId of + Private.SpanId idInfo -> return idInfo + Private.SpanQQ _ -> Nothing + Private.SpanInSplice idInfo -> return idInfo + return $ map (removeExplicitSharing computedCache) + . concatMap (maybeListToList . StrictMap.lookup idProp) + $ StrictMap.elems computedUseSites + where + maybeListToList :: Maybe [a] -> [a] + maybeListToList (Just xs) = xs + maybeListToList Nothing = [] + +-- | Minimal .cabal file for the loaded modules seen as a library. +-- The argument specifies the name of the library. +-- +-- License is set to @AllRightsReserved@. +-- All transitive package dependencies are included, +-- with package versions set to the currently used versions. +-- Only modules that get compiled successfully are included. +-- Source directory is the currently used session source directory. +-- Warning: all modules named @Main@ (even in subdirectories +-- or files with different names) are ignored so that they +-- don't get in the way when we build an executable using the library +-- and so that the behaviour is consistent with that of @buildExe@. +getDotCabal :: Query (String -> Version -> BSL.ByteString) +getDotCabal session = withComputedState session + $ \idleState computed@Computed{..} -> do + let sourcesDir = ideSessionSourceDir . ideSessionDir $ ideStaticInfo session + options = idleState ^. ideGhcOpts + relativeIncludes = idleState ^. ideRelativeIncludes + buildDotCabal sourcesDir relativeIncludes options computed + +{------------------------------------------------------------------------------ + Debugging +------------------------------------------------------------------------------} + +-- | Print the id info maps to stdout (for debugging purposes only) +dumpIdInfo :: IdeSession -> IO () +dumpIdInfo session = withComputedState session $ \_ Computed{..} -> + forM_ (StrictMap.toList computedSpanInfo) $ \(mod, idMap) -> do + putStrLn $ "*** " ++ Text.unpack mod ++ " ***" + forM_ (StrictIntervalMap.toList (Private.idMapToMap idMap)) $ \(i, idInfo) -> do + let idInfo' = removeExplicitSharing computedCache idInfo + (StrictIntervalMap.Interval (fn, fromLine, fromCol) (_, toLine, toCol)) = i + fn' = dereferenceFilePathPtr computedCache fn + putStrLn $ show (fn', fromLine, fromCol, toLine, toCol) ++ ": " ++ show idInfo' + +-- | Print autocompletion to stdout (for debugging purposes only) +dumpAutocompletion :: IdeSession -> IO () +dumpAutocompletion session = withComputedState session $ \_ Computed{..} -> + forM_ (StrictMap.toList computedAutoMap) $ \(mod, autoMap) -> do + putStrLn $ "*** " ++ Text.unpack mod ++ " ***" + forM_ (StrictTrie.toList autoMap) $ \(key, idInfos) -> + forM_ (toLazyList idInfos) $ \idInfo -> do + let idInfo' :: IdInfo + idInfo' = removeExplicitSharing computedCache idInfo + putStrLn $ show key ++ ": " ++ show idInfo' + +-- | Print file mapping to stdout (for debugging purposes only) +dumpFileMap :: IdeSession -> IO () +dumpFileMap session = withComputedState session $ \_ Computed{..} -> + forM_ (StrictMap.toList computedFileMap) $ \(path, mod) -> do + let mod' = removeExplicitSharing computedCache mod + putStrLn $ path ++ ": " ++ show mod' + +{------------------------------------------------------------------------------ + Auxiliary +------------------------------------------------------------------------------} + +-- | For the purposes of queries, we pretend that the 'IdeSessionServerDied' +-- state is a regular state, but we report the exception as a 'SourceError' +withIdleState :: IdeSession -> (IdeIdleState -> IO a) -> IO a +withIdleState IdeSession{ideState} f = + $withStrictMVar ideState $ \st -> + case st of + IdeSessionIdle idleState -> f idleState + IdeSessionServerDied e idleState -> f (reportExAsErr e idleState) + IdeSessionShutdown -> fail "Session already shut down." + where + reportExAsErr :: ExternalException -> IdeIdleState -> IdeIdleState + reportExAsErr e = ideComputed ^: + StrictMaybe.just . updateComputed e . StrictMaybe.fromMaybe emptyComputed + + updateComputed :: ExternalException -> Computed -> Computed + updateComputed (ExternalException remote _local) c = + let err = Private.SourceError { + Private.errorKind = Private.KindServerDied + , Private.errorSpan = Private.TextSpan (Text.pack "<>") + , Private.errorMsg = Text.pack remote + } + in c { computedErrors = StrictList.singleton err } + + -- TODO: Do we really want an empty computed here? This means that if the + -- user does not check getSourceErrors they might get nil/empty rather + -- than an error. + emptyComputed :: Computed + emptyComputed = Computed { + computedErrors = StrictList.nil + , computedLoadedModules = StrictList.nil + , computedFileMap = StrictMap.empty + , computedSpanInfo = StrictMap.empty + , computedExpTypes = StrictMap.empty + , computedUseSites = StrictMap.empty + , computedImports = StrictMap.empty + , computedAutoMap = StrictMap.empty + , computedPkgDeps = StrictMap.empty + , computedCache = Private.ExplicitSharingCache { + Private.filePathCache = StrictIntMap.empty + , Private.idPropCache = StrictIntMap.empty + } + } + +withComputedState :: IdeSession -> (IdeIdleState -> Computed -> IO a) -> IO a +withComputedState session f = withIdleState session $ \idleState -> + case toLazyMaybe (idleState ^. ideComputed) of + Just computed -> f idleState computed + Nothing -> throwIO InvalidSessionStateQueries + +data InvalidSessionStateQueries = InvalidSessionStateQueries + deriving Typeable +instance Show InvalidSessionStateQueries where + show InvalidSessionStateQueries = "This session state does not admit queries." +instance Exception InvalidSessionStateQueries + +staticQuery :: (IdeStaticInfo -> IO a) -> Query a +staticQuery f = f . ideStaticInfo + +simpleQuery :: (IdeIdleState -> a) -> Query a +simpleQuery f session = withIdleState session $ return . f + +computedQuery :: (Computed -> a) -> Query a +computedQuery f session = withComputedState session $ const (return . f) diff --git a/IdeSession/RPC/API.hs b/IdeSession/RPC/API.hs new file mode 100644 --- /dev/null +++ b/IdeSession/RPC/API.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DeriveDataTypeable, RankNTypes #-} +module IdeSession.RPC.API ( + -- * External exceptions + ExternalException(..) + , serverKilledException + -- * Client-server communication + , RpcConversation(..) + , Request(..) + , Response(..) + -- * Lazy bytestring with incremental Binary instance + , IncBS(..) + -- * IO utils + , hPutFlush + , ignoreIOExceptions + , openPipeForWriting + , openPipeForReading + ) where + +import Prelude hiding (take) +import Control.Applicative ((<$>)) +import Control.Concurrent (threadDelay) +import Data.Binary (Binary) +import Data.Typeable (Typeable) +import System.IO (Handle, hFlush, openFile, IOMode(..), hPutChar, hGetChar) +import qualified Control.Exception as Ex +import qualified Data.Binary as Binary +import qualified Data.ByteString as BSS +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.ByteString.Lazy.Internal as BSL + +-------------------------------------------------------------------------------- +-- Exceptions thrown by the RPC server are retrown locally as -- +-- 'ExternalException's -- +-------------------------------------------------------------------------------- + +-- | Exceptions thrown by the remote server +data ExternalException = ExternalException { + -- | The output from the server on stderr + externalStdErr :: String + -- | The local exception that was thrown and alerted us to the problem + , externalException :: Maybe Ex.IOException + } + deriving (Eq, Typeable) + +instance Show ExternalException where + show (ExternalException err Nothing) = + "External exception: " ++ err + show (ExternalException err (Just ex)) = + "External exception: " ++ err ++ ". Local exception: " ++ show ex + +instance Ex.Exception ExternalException + +-- | Generic exception thrown if the server gets killed for unknown reason +serverKilledException :: Maybe Ex.IOException -> ExternalException +serverKilledException ex = ExternalException "Server killed" ex + +{------------------------------------------------------------------------------ + Client-server communication +------------------------------------------------------------------------------} + +data RpcConversation = RpcConversation { + get :: forall a. (Typeable a, Binary a) => IO a + , put :: forall a. (Typeable a, Binary a) => a -> IO () + } + +data Request = Request IncBS | RequestShutdown + deriving Show + +newtype Response = Response IncBS + +instance Binary Request where + put (Request bs) = Binary.putWord8 0 >> Binary.put bs + put RequestShutdown = Binary.putWord8 1 + + get = do + header <- Binary.getWord8 + case header of + 0 -> Request <$> Binary.get + 1 -> return RequestShutdown + _ -> fail "Request.get: invalid header" + +instance Binary Response where + put (Response bs) = Binary.put bs + get = Response <$> Binary.get + +{------------------------------------------------------------------------------ + Lazy bytestring with an incremental Binary instance + + Note only does this avoid loading the entire ByteString into memory when + serializing stuff, the standard Binary instance for Lazy bytestring is + actually broken in 0.5 (http://hpaste.org/87401; fixed in 0.7, but even there + still requires the length of the bytestring upfront). +------------------------------------------------------------------------------} + +newtype IncBS = IncBS { unIncBS :: BSL.ByteString } + +instance Binary IncBS where + put (IncBS BSL.Empty) = Binary.putWord8 0 + put (IncBS (BSL.Chunk b bs)) = do Binary.putWord8 1 + Binary.put b + Binary.put (IncBS bs) + + get = go [] + where + go :: [BSS.ByteString] -> Binary.Get IncBS + go acc = do + header <- Binary.getWord8 + case header of + 0 -> return . IncBS . BSL.fromChunks . reverse $ acc + 1 -> do b <- Binary.get ; go (b : acc) + _ -> fail "IncBS.get: invalid header" + +instance Show IncBS where + show = show . unIncBS + +{------------------------------------------------------------------------------ + Some IO utils +------------------------------------------------------------------------------} + +-- | Write a bytestring to a buffer and flush +hPutFlush :: Handle -> BSL.ByteString -> IO () +hPutFlush h bs = BSL.hPut h bs >> ignoreIOExceptions (hFlush h) + +-- | Ignore IO exceptions +ignoreIOExceptions :: IO () -> IO () +ignoreIOExceptions = Ex.handle ignore + where + ignore :: Ex.IOException -> IO () + ignore _ = return () + +-- | Open a pipe for writing +-- +-- This is meant to be used together with 'openPipeForReading' +openPipeForWriting :: FilePath -> Int -> IO Handle +openPipeForWriting fp = go + where + go :: Int -> IO Handle + go timeout = do + -- We cannot open a pipe for writing without a corresponding reader + mh <- Ex.try $ openFile fp WriteMode + case mh of + Left ex -> + if timeout > delay + then do threadDelay delay + go (timeout - delay) + else Ex.throwIO (RPCPipeNotCreated ex) + Right h -> do + hPutChar h '!' + hFlush h + return h + + delay :: Int + delay = 10000 -- 10 ms + +data RPCPipeNotCreated = RPCPipeNotCreated Ex.IOException + deriving Typeable +instance Ex.Exception RPCPipeNotCreated +instance Show RPCPipeNotCreated where + show (RPCPipeNotCreated e) = "The bidirectional RPC pipe could not be opened. Exception was: " ++ show e + +-- | Open a pipe for reading +-- +-- This is meant to be used together with 'openPipeForWriting' +openPipeForReading :: FilePath -> Int -> IO Handle +openPipeForReading fp = \timeout -> do + -- We _can_ open a pipe for reading without a corresponding writer + h <- openFile fp ReadMode + -- But if there is no corresponding writer, then trying to read from the + -- pipe will report EOF. So we wait. + go h timeout + return h + where + go :: Handle -> Int -> IO () + go h timeout = do + mc <- Ex.try $ hGetChar h + case mc of + Left ex -> + if timeout > delay + then do threadDelay delay + go h (timeout - delay) + else Ex.throwIO (RPCPipeNotCreated ex) + Right '!' -> + return () + Right c -> + Ex.throwIO (userError $ "openPipeForReading: Unexpected " ++ show c) + + delay :: Int + delay = 10000 -- 10 ms diff --git a/IdeSession/RPC/Client.hs b/IdeSession/RPC/Client.hs new file mode 100644 --- /dev/null +++ b/IdeSession/RPC/Client.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE TemplateHaskell, CPP, ScopedTypeVariables #-} +module IdeSession.RPC.Client ( + RpcServer + , RpcConversation(..) + , forkRpcServer + , connectToRpcServer + , rpc + , rpcConversation + , shutdown + , forceShutdown + , ExternalException(..) + , illscopedConversationException + , serverKilledException + , getRpcExitCode + ) where + +import Control.Concurrent.MVar (MVar, newMVar, tryTakeMVar) +import Control.Monad (void, unless) +import Data.Binary (Binary, encode, decode) +import Data.IORef (writeIORef, readIORef, newIORef) +import Data.Typeable (Typeable) +import Prelude hiding (take) +import System.Exit (ExitCode) +import System.IO (Handle, hClose) +import System.IO.Temp (openTempFile) +import System.Posix.IO (createPipe, closeFd, fdToHandle) +import System.Posix.Signals (signalProcess, sigKILL) +import System.Posix.Types (Fd) +import System.Process + ( createProcess + , proc + , ProcessHandle + , waitForProcess + , CreateProcess(cwd, env) + , getProcessExitCode + ) +import System.Process.Internals (withProcessHandle, ProcessHandle__(..)) +import qualified Control.Exception as Ex +import qualified System.Directory as Dir + +import IdeSession.Util.BlockingOps +import IdeSession.RPC.API +import IdeSession.RPC.Stream + +-------------------------------------------------------------------------------- +-- Client-side API -- +-------------------------------------------------------------------------------- + +-- | Abstract data type representing RPC servers +data RpcServer = RpcServer { + -- | Handle to write requests to + rpcRequestW :: Handle + -- | Temporary file the server will write uncaught exceptions to + , rpcErrorLog :: FilePath + -- | Handle on the server process itself + -- + -- This is Nothing if we connected to an existing RPC server + -- ('connectToRpcServer') rather than started a new server + -- ('forkRpcServer') + , rpcProc :: Maybe ProcessHandle + -- | IORef containing the server response stream + , rpcResponseR :: Stream Response + -- | Server state + , rpcState :: MVar RpcClientSideState + -- | Identity of this server (for debugging purposes) + , rpcIdentity :: String + } + +-- | RPC server state +data RpcClientSideState = + -- | The server is running. + RpcRunning + -- | The server was stopped, either manually or because of an exception + | RpcStopped Ex.SomeException + +-- | Fork an RPC server as a separate process +-- +-- @forkRpcServer exec args@ starts executable @exec@ with arguments +-- @args ++ args'@ where @args'@ are internal arguments generated by +-- 'forkRpcServer'. These internal arguments should be passed as arguments +-- to 'rpcServer'. +-- +-- As a typical example, you might pass @["--server"]@ as @args@, and the +-- 'main' function of @exec@ might look like +-- +-- > main = do +-- > args <- getArgs +-- > case args of +-- > "--server" : args' -> +-- > rpcServer args' <> +-- > _ -> +-- > <> +forkRpcServer :: FilePath -- ^ Filename of the executable + -> [String] -- ^ Arguments + -> Maybe FilePath -- ^ Working directory + -> Maybe [(String, String)] -- ^ Environment + -> IO RpcServer +forkRpcServer path args workingDir menv = do + (requestR, requestW) <- createPipe + (responseR, responseW) <- createPipe + + tmpDir <- Dir.getTemporaryDirectory + (errorLogPath, errorLogHandle) <- openTempFile tmpDir "rpc-server-.log" + hClose errorLogHandle + + let showFd :: Fd -> String + showFd fd = show (fromIntegral fd :: Int) + + let args' = args + ++ [errorLogPath] + ++ map showFd [requestR, requestW, responseR, responseW] + + fullPath <- pathToExecutable path + (Nothing, Nothing, Nothing, ph) <- createProcess (proc fullPath args') { + cwd = workingDir, + env = menv + } + + -- Close the ends of the pipes that we're not using, and convert the rest + -- to handles + closeFd requestR + closeFd responseW + requestW' <- fdToHandle requestW + responseR' <- fdToHandle responseR + + st <- newMVar RpcRunning + input <- newStream responseR' + return RpcServer { + rpcRequestW = requestW' + , rpcErrorLog = errorLogPath + , rpcProc = Just ph + , rpcState = st + , rpcResponseR = input + , rpcIdentity = path + } + where + pathToExecutable :: FilePath -> IO FilePath + pathToExecutable relPath = do + fullPath <- Dir.canonicalizePath relPath + permissions <- Dir.getPermissions fullPath + if Dir.executable permissions + then return fullPath + else Ex.throwIO . userError $ relPath ++ " not executable" + +-- | Connect to an existing RPC server +-- +-- It is the responsibility of the caller to make sure that each triplet +-- of named pipes is only used for RPC connection. +connectToRpcServer :: FilePath -- ^ stdin named pipe + -> FilePath -- ^ stdout named pipe + -> FilePath -- ^ logfile for storing exceptions + -> (RpcServer -> IO a) + -> IO a +connectToRpcServer requestW responseR errorLog act = + Ex.bracket (openPipeForWriting requestW timeout) hClose $ \requestW' -> + Ex.bracket (openPipeForReading responseR timeout) hClose $ \responseR' -> do + st <- newMVar RpcRunning + input <- newStream responseR' + act $ RpcServer { + rpcRequestW = requestW' + , rpcErrorLog = errorLog + , rpcProc = Nothing + , rpcState = st + , rpcResponseR = input + , rpcIdentity = requestW + } + where + timeout :: Int + timeout = 1000000 -- 1sec + +-- | Specialized form of 'rpcConversation' to do single request and wait for +-- a single response. +rpc :: (Typeable req, Typeable resp, Binary req, Binary resp) => RpcServer -> req -> IO resp +rpc server req = rpcConversation server $ \RpcConversation{..} -> put req >> get + +-- | Run an RPC conversation. If the handler throws an exception during +-- the conversation the server is terminated. +rpcConversation :: RpcServer + -> (RpcConversation -> IO a) + -> IO a +rpcConversation server handler = withRpcServer server $ \st -> + case st of + RpcRunning -> do + -- We want to be able to detect when a conversation is used out of scope + inScope <- newIORef True + + -- Call the handler, update the state, and return the result + a <- handler . conversation $ do isInScope <- readIORef inScope + unless isInScope $ + Ex.throwIO illscopedConversationException + + -- Record that the conversation is no longer in scope and return + writeIORef inScope False + return (RpcRunning, a) + RpcStopped ex -> + Ex.throwIO ex + where + conversation :: IO () -> RpcConversation + conversation verifyScope = RpcConversation { + put = \req -> do + verifyScope + mapIOToExternal server $ do + let msg = encode $ Request (IncBS $ encode req) + hPutFlush (rpcRequestW server) msg + , get = do verifyScope + mapIOToExternal server $ do + Response resp <- nextInStream (rpcResponseR server) + Ex.evaluate $ decode (unIncBS resp) + } + +illscopedConversationException :: Ex.IOException +illscopedConversationException = + userError "Attempt to use RPC conversation outside its scope" + +-- | Shut down the RPC server +-- +-- This simply kills the remote process. If you want to shut down the remote +-- process cleanly you must implement your own termination protocol before +-- calling 'shutdown'. +shutdown :: RpcServer -> IO () +shutdown server = withRpcServer server $ \_ -> do + terminate server + ignoreIOExceptions $ Dir.removeFile (rpcErrorLog server) + let ex = Ex.toException (userError "Manual shutdown") + return (RpcStopped ex, ()) + +-- | Force shutdown. +-- +-- In order to faciliate a force shutdown while another thread may be +-- communicating with the RPC server, we _try_ to update the MVar underlying +-- the RPC server, but if we fail, we terminate the server anyway. This means +-- that this may leave the 'RpcServer' in an invalid state -- so you shouldn't +-- be using it anymore after calling forceShutdown! +forceShutdown :: RpcServer -> IO () +forceShutdown server = Ex.mask_ $ do + mst <- tryTakeMVar (rpcState server) + + ignoreIOExceptions $ forceTerminate server + ignoreIOExceptions $ Dir.removeFile (rpcErrorLog server) + + case mst of + Nothing -> -- We failed to take the MVar. Shrug. + return () + Just _ -> do + let ex = Ex.toException (userError "Forced manual shutdown") + $putMVar (rpcState server) (RpcStopped ex) + +-- | Terminate the RPC connection +-- +-- If we connected using 'forkRpcServer' (rather than 'connectToRpcServer') +-- we wait for the remote process to terminate. +terminate :: RpcServer -> IO () +terminate server = do + ignoreIOExceptions $ hPutFlush (rpcRequestW server) (encode RequestShutdown) + case rpcProc server of + Just ph -> void $ waitForProcess ph + Nothing -> return () + +-- | Force-terminate the external process +-- +-- Throws an exception when we are connected to an existing RPC server +forceTerminate :: RpcServer -> IO () +forceTerminate server = + case rpcProc server of + Just ph -> + withProcessHandle ph $ \p_ -> + case p_ of + ClosedHandle _ -> + leaveHandleAsIs p_ + OpenHandle pID -> do + signalProcess sigKILL pID + leaveHandleAsIs p_ + Nothing -> + Ex.throwIO $ userError "forceTerminate: parallel connection" + where + leaveHandleAsIs _p = +#if MIN_VERSION_process(1,2,0) + return () +#else + return (_p, ()) +#endif + +-- | Like modifyMVar, but terminate the server on exceptions +withRpcServer :: RpcServer + -> (RpcClientSideState -> IO (RpcClientSideState, a)) + -> IO a +withRpcServer server io = + Ex.mask $ \restore -> do + st <- $takeMVar (rpcState server) + + mResult <- Ex.try $ restore (io st) + + case mResult of + Right (st', a) -> do + $putMVar (rpcState server) st' + return a + Left ex -> do + -- terminate server + $putMVar (rpcState server) (RpcStopped (Ex.toException (userError (rpcIdentity server ++ ": " ++ show (ex :: Ex.SomeException))))) + Ex.throwIO ex + +-- | Get the exit code of the RPC server, unless still running. +-- +-- Thross an exception for connections to existing RPC servers. +getRpcExitCode :: RpcServer -> IO (Maybe ExitCode) +getRpcExitCode RpcServer{rpcProc} = + case rpcProc of + Just ph -> getProcessExitCode ph + Nothing -> Ex.throwIO $ userError "getRpcExitCode: parallel connection" + +{------------------------------------------------------------------------------ + Aux +------------------------------------------------------------------------------} + +-- | Map IO exceptions to external exceptions, using the error written +-- by the server (if any) +mapIOToExternal :: RpcServer -> IO a -> IO a +mapIOToExternal server p = Ex.catch p $ \ex -> do + let _ = ex :: Ex.IOException + merr <- readFile (rpcErrorLog server) + if null merr + then Ex.throwIO (serverKilledException (Just ex)) + else Ex.throwIO (ExternalException merr (Just ex)) + diff --git a/IdeSession/RPC/Server.hs b/IdeSession/RPC/Server.hs new file mode 100644 --- /dev/null +++ b/IdeSession/RPC/Server.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, DeriveDataTypeable, RankNTypes, GADTs #-} +{-# OPTIONS_GHC -Wall #-} +module IdeSession.RPC.Server + ( rpcServer + , concurrentConversation + , RpcConversation(..) + ) where + +import Prelude hiding (take) +import System.IO + ( Handle + , hSetBinaryMode + , hSetBuffering + , BufferMode(BlockBuffering) + ) +import System.Posix.Types (Fd) +import System.Posix.IO (closeFd, fdToHandle) +import Control.Monad (void) +import qualified Control.Exception as Ex +import Control.Concurrent (threadDelay) +import Control.Concurrent.Chan (Chan, newChan, writeChan) +import qualified Data.ByteString.Lazy.Char8 as BSL +import Control.Concurrent.Async (Async, async) +import Data.Binary (encode, decode) + +import IdeSession.Util.BlockingOps (readChan, wait, waitAny) +import IdeSession.RPC.API +import IdeSession.RPC.Stream + +-------------------------------------------------------------------------------- +-- Server-side API -- +-------------------------------------------------------------------------------- + +-- Start the RPC server. For an explanation of the command line arguments, see +-- 'forkRpcServer'. This function does not return until the client requests +-- termination of the RPC conversation (or there is an error). +-- +-- The server is passed the RpcConversation to communicate with the client, +-- as well as the path to the exception log (rarely needed -- only needed +-- if the server thread kills the whole process unconditionally, without +-- throwing an exception). +rpcServer :: (FilePath -> RpcConversation -> IO ()) -- ^ Request server + -> [String] -- ^ Command line args + -> IO () +rpcServer handler args = do + let readFd :: String -> Fd + readFd fd = fromIntegral (read fd :: Int) + + let errorLog : fds = args + [requestR, requestW, responseR, responseW] = map readFd fds + + closeFd requestW + closeFd responseR + requestR' <- fdToHandle requestR + responseW' <- fdToHandle responseW + + rpcServer' requestR' responseW' errorLog handler + +-- | Start a concurrent conversation. +concurrentConversation :: FilePath -- ^ stdin named pipe + -> FilePath -- ^ stdout named pipe + -> FilePath -- ^ log file for exceptions + -> (FilePath -> RpcConversation -> IO ()) + -> IO () +concurrentConversation requestR responseW errorLog server = do + hin <- openPipeForReading requestR timeout + hout <- openPipeForWriting responseW timeout + rpcServer' hin hout errorLog server + where + timeout :: Int + timeout = maxBound + +-- | Start the RPC server +rpcServer' :: Handle -- ^ Input + -> Handle -- ^ Output + -> FilePath -- ^ Log file for exceptions + -> (FilePath -> RpcConversation -> IO ()) -- ^ The request server + -> IO () +rpcServer' hin hout errorLog server = do + requests <- newChan :: IO (Chan BSL.ByteString) + responses <- newChan :: IO (Chan (Maybe BSL.ByteString)) + + setBinaryBlockBuffered [hin, hout] + + -- Each thread installs it own exception handler before unmasking + -- asynchronous exceptions. This way when an exception occurs we can + -- identify it (by looking at which ServerEvent was returned). + (reader, writer, handler) <- Ex.mask $ \restore -> do + reader <- async $ readRequests restore hin requests + writer <- async $ writeResponses restore responses hout + handler <- async $ channelHandler restore requests responses (server errorLog) + return (reader, writer, handler) + + (_thread, ev) <- $waitAny [reader, writer, handler] + case ev of + -- If we lose connection with the client, just terminate. + -- See #194 (in particular, https://github.com/fpco/ide-backend/issues/194#issuecomment-44210412) + LostConnection ex -> + tryShowException (Just ex) + + -- If the client requests termination, we simply terminate immediately. + -- It is the client's responsibility to have a proper shutdown protocol + -- with the server thread + ReaderThreadTerminated -> + return () + + -- The writer thread should never terminate normally unless we request + -- it; this is a logical impossibility :) + WriterThreadTerminated -> + error "The impossible happened" + + -- When the main server thread terminates we ask the writer thread to + -- terminate so that we make sure to send any pending messages + ServerThreadTerminated -> + tryShowException =<< flushResponses responses writer + + -- When the main server thread aborts, we still attempt to flush any + -- remaining messages, but the exception that we record is the one from + -- the server (the writer thread might terminate with a further exception) + ServerThreadAborted ex -> do + tryShowException (Just ex) + void $ flushResponses responses writer + + threadDelay 100000 + where + tryShowException :: Maybe Ex.SomeException -> IO () + tryShowException (Just ex) = + ignoreIOExceptions $ appendFile errorLog (show ex) + tryShowException Nothing = + return () + +-------------------------------------------------------------------------------- +-- Internal -- +-------------------------------------------------------------------------------- + +-- | We record the reason why the various threads are terminating, so that we +-- can take the appropriate action +data ServerEvent = + -- | The reader thread terminates when the client sends a 'RequestShutdown' + -- message + ReaderThreadTerminated + + -- | After the main server thread terminates, we wait for the writer thread + -- to terminate to make sure there are no pending unsent messages + | WriterThreadTerminated + + -- | Termination of the main server thread + | ServerThreadTerminated + + -- | Main server thread threw an exception + | ServerThreadAborted Ex.SomeException + + -- | The reader thread and writer threads terminate with 'LostConnection' + -- if an exception occurs + | LostConnection Ex.SomeException + deriving Show + +-- | Decode messages from a handle and forward them to a channel. +-- The boolean result indicates whether the shutdown is forced. +readRequests :: Restore -> Handle -> Chan BSL.ByteString -> IO ServerEvent +readRequests restore h ch = + Ex.handle (return . LostConnection) + (restore (newStream h >>= go)) + where + go :: Stream Request -> IO ServerEvent + go input = do + req <- nextInStream input + case req of + Request req' -> writeChan ch (unIncBS req') >> go input + RequestShutdown -> return ReaderThreadTerminated + +-- | Encode messages from a channel and forward them on a handle +-- +-- Terminates on 'Nothing'. +writeResponses :: Restore -> Chan (Maybe BSL.ByteString) -> Handle -> IO ServerEvent +writeResponses restore ch h = + Ex.handle (return . LostConnection) + (restore go) + where + go :: IO ServerEvent + go = do + mbs <- $readChan ch + case mbs of + Just bs -> do hPutFlush h $ encode (Response (IncBS bs)) ; go + Nothing -> return WriterThreadTerminated + +-- | Ask the writer thread to terminate and wait for all remaining messages to +-- have been sent. Returns 'Nothing' if the writer thread terminated normally, +-- or the exception if it didn't. +flushResponses :: Chan (Maybe BSL.ByteString) -> Async ServerEvent -> IO (Maybe Ex.SomeException) +flushResponses responses writer = do + writeChan responses Nothing + ev <- $wait writer + case ev of + WriterThreadTerminated -> + return Nothing + LostConnection ex -> + return (Just ex) + _ -> + error "the impossible happened" + +-- | Run a handler repeatedly, given input and output channels +channelHandler :: Restore + -> Chan BSL.ByteString + -> Chan (Maybe BSL.ByteString) + -> (RpcConversation -> IO ()) + -> IO ServerEvent +channelHandler restore requests responses server = + Ex.handle (return . ServerThreadAborted) + (restore go) + where + go :: IO ServerEvent + go = do + server RpcConversation { + get = $readChan requests >>= Ex.evaluate . decode + , put = writeChan responses . Just . encode + } + return ServerThreadTerminated + +-------------------------------------------------------------------------------- +-- Auxiliary -- +-------------------------------------------------------------------------------- + +type Restore = forall a. IO a -> IO a + +-- | Set all the specified handles to binary mode and block buffering +setBinaryBlockBuffered :: [Handle] -> IO () +setBinaryBlockBuffered = + mapM_ $ \h -> do hSetBinaryMode h True + hSetBuffering h (BlockBuffering Nothing) diff --git a/IdeSession/RPC/Stream.hs b/IdeSession/RPC/Stream.hs new file mode 100644 --- /dev/null +++ b/IdeSession/RPC/Stream.hs @@ -0,0 +1,47 @@ +-- | Wrapper around binary +{-# LANGUAGE ScopedTypeVariables, GADTs #-} +module IdeSession.RPC.Stream ( + Stream + , newStream + , nextInStream + ) where + +import Prelude hiding (take) +import System.IO (Handle) +import qualified Control.Exception as Ex +import qualified Data.ByteString.Lazy.Internal as BSL +import qualified Data.ByteString as BSS +import Data.IORef (IORef, writeIORef, readIORef, newIORef) +import Data.Binary (Binary) +import qualified Data.Binary as Binary +import qualified Data.Binary.Get as Binary + +data Stream a where + Stream :: Binary a => Handle -> IORef (Binary.Decoder a) -> Stream a + +newStream :: Binary a => Handle -> IO (Stream a) +newStream h = do + st <- newIORef $ Binary.runGetIncremental Binary.get + return $ Stream h st + +nextInStream :: forall a. Stream a -> IO a +nextInStream (Stream h st) = readIORef st >>= go + where + go :: Binary.Decoder a -> IO a + go decoder = case decoder of + Binary.Fail _ _ err -> do + writeIORef st decoder + Ex.throwIO (userError err) + Binary.Partial k -> do + mchunk <- Ex.try $ BSS.hGetSome h BSL.defaultChunkSize + case mchunk of + Left ex -> do writeIORef st decoder + Ex.throwIO (ex :: Ex.SomeException) + Right chunk | BSS.null chunk -> go . k $ Nothing + | otherwise -> go . k $ Just chunk + Binary.Done unused _numConsumed a -> do + writeIORef st $ contDecoder unused + return a + + contDecoder :: BSS.ByteString -> Binary.Decoder a + contDecoder = Binary.pushChunk (Binary.runGetIncremental Binary.get) diff --git a/IdeSession/State.hs b/IdeSession/State.hs new file mode 100644 --- /dev/null +++ b/IdeSession/State.hs @@ -0,0 +1,259 @@ +-- | Internal state of the session +-- +-- This uses the internal types only. +module IdeSession.State + ( -- * Types + Computed(..) + , IdeSession(..) + , IdeStaticInfo(..) + , IdeSessionState(..) + , LogicalTimestamp + , IdeIdleState(..) + , ManagedFilesInternal(..) + , ManagedFile + , GhcServer(..) + , RunActions(..) + -- * Accessors + , ideLogicalTimestamp + , ideComputed + , ideGhcOpts + , ideRelativeIncludes + , ideGenerateCode + , ideManagedFiles + , ideObjectFiles + , ideBuildExeStatus + , ideBuildDocStatus + , ideBuildLicensesStatus + , ideEnv + , ideArgs + , ideGhcServer + , ideGhcVersion + , ideStdoutBufferMode + , ideStderrBufferMode + , ideBreakInfo + , ideTargets + , ideRtsOpts + , managedSource + , managedData + ) where + +import Control.Concurrent (ThreadId) +import Data.Accessor (Accessor, accessor) +import Data.Digest.Pure.MD5 (MD5Digest) +import System.Exit (ExitCode) +import System.Posix.Types (EpochTime) +import qualified Data.ByteString as BSS + +import IdeSession.Config +import IdeSession.GHC.API (GhcVersion) +import IdeSession.RPC.Client (RpcServer, RpcConversation, ExternalException) +import IdeSession.Strict.Container +import IdeSession.Strict.MVar (StrictMVar) +import IdeSession.Types.Private hiding (RunResult) +import qualified IdeSession.Types.Public as Public + +data Computed = Computed { + -- | Last compilation and run errors + computedErrors :: !(Strict [] SourceError) + -- | Modules that got loaded okay + , computedLoadedModules :: !(Strict [] ModuleName) + -- | Mapping from filepaths to the modules they define + , computedFileMap :: !(Strict (Map FilePath) ModuleId) + -- | Import information. This is (usually) available even for modules + -- with parsing or type errors + , computedImports :: !(Strict (Map ModuleName) (Strict [] Import)) + -- | Autocompletion map + -- + -- Mapping, per module, from prefixes to fully qualified names + -- I.e., @fo@ might map to @Control.Monad.forM@, @Control.Monad.forM_@ + -- etc. (or possibly to @M.forM@, @M.forM_@, etc when Control.Monad + -- was imported qualified as @M@). + , computedAutoMap :: !(Strict (Map ModuleName) (Strict Trie (Strict [] IdInfo))) + -- | Information about identifiers/quasi-quotes + , computedSpanInfo :: !(Strict (Map ModuleName) IdMap) + -- | Type information about subexpressions + , computedExpTypes :: !(Strict (Map ModuleName) ExpMap) + -- | Use sites + , computedUseSites :: !(Strict (Map ModuleName) UseSites) + -- | (Transitive) package dependencies + , computedPkgDeps :: !(Strict (Map ModuleName) (Strict [] PackageId)) + -- | We access IdProps indirectly through this cache + , computedCache :: !ExplicitSharingCache + } + deriving Show + +-- | This type is a handle to a session state. Values of this type +-- point to the non-persistent parts of the session state in memory +-- and to directories containing source and data file that form +-- the persistent part of the session state. Whenever we perform updates +-- or run queries, it's always in the context of a particular handle, +-- representing the session we want to work within. Many sessions +-- can be active at once, but in normal applications this shouldn't be needed. +-- +data IdeSession = IdeSession { + ideStaticInfo :: IdeStaticInfo + , ideState :: StrictMVar IdeSessionState + } + +data IdeStaticInfo = IdeStaticInfo { + -- | Configuration + ideConfig :: SessionConfig + -- | (Temporary) directory for session files + -- + -- See also: + -- * 'ideSessionSourceDir' + -- * 'ideSessionDataDir', + -- * 'ideSessionDistDir' + , ideSessionDir :: FilePath + } + +data IdeSessionState = + IdeSessionIdle IdeIdleState + | IdeSessionShutdown + | IdeSessionServerDied ExternalException IdeIdleState + +type LogicalTimestamp = EpochTime + +-- TODO: We should split this into local state and (cached) "remote" state. +-- Then we can change IdeSessionUpdate to have access to the local state only +-- (IdeSessionUpdates _schedules_ remote updates, but doesn't run them; this +-- happens only in updateSession). +data IdeIdleState = IdeIdleState { + -- | A workaround for http://hackage.haskell.org/trac/ghc/ticket/7473. + -- Logical timestamps (used to force ghc to recompile files) + _ideLogicalTimestamp :: !LogicalTimestamp + -- | The result computed by the GHC API typing/compilation invocation + -- in the last call to 'updateSession' invocation. + , _ideComputed :: !(Strict Maybe Computed) + -- | Current GHC options + , _ideGhcOpts :: ![String] + -- | Include paths (equivalent of GHC's @-i@ parameter) relative to the + -- temporary directory where we store the session's source files. + -- The initial value, used also for server startup, is taken from + -- 'configRelativeIncludes'. + -- + -- By default this is the singleton list @[""]@ -- i.e., we include the + -- sources dir (located there in simple setups, e.g., ide-backend tests) + -- but nothing else. + , _ideRelativeIncludes :: ![FilePath] + -- | Whether to generate code in addition to type-checking. + , _ideGenerateCode :: !Bool + -- | Files submitted by the user and not deleted yet. + , _ideManagedFiles :: !ManagedFilesInternal + -- | Object files created from .c files + , _ideObjectFiles :: !ObjectFiles + -- | Exit status of the last invocation of 'buildExe', if any. + , _ideBuildExeStatus :: !(Maybe ExitCode) + -- | Exit status of the last invocation of 'buildDoc', if any. + , _ideBuildDocStatus :: !(Maybe ExitCode) + -- | Exit status of the last invocation of 'buildDoc', if any. + , _ideBuildLicensesStatus :: !(Maybe ExitCode) + -- | Environment overrides + , _ideEnv :: ![(String, Maybe String)] + -- | Command line arguments for snippets (expected value of `getArgs`) + , _ideArgs :: ![String] + -- | The GHC server (this is replaced in 'restartSession') + , _ideGhcServer :: GhcServer -- Intentionally lazy + -- | GHC version + , _ideGhcVersion :: GhcVersion -- Intentionally lazy + -- | Buffer mode for standard output for 'runStmt' + , _ideStdoutBufferMode :: !Public.RunBufferMode + -- | Buffer mode for standard error for 'runStmt' + , _ideStderrBufferMode :: !Public.RunBufferMode + -- | Are we currently in a breakpoint? + , _ideBreakInfo :: !(Strict Maybe Public.BreakInfo) + -- | Targets for compilation + , _ideTargets :: !Public.Targets + -- | RTS options (for the ghc session, not for executables) + , _ideRtsOpts :: [String] + } + +-- | The collection of source and data files submitted by the user. +data ManagedFilesInternal = ManagedFilesInternal + { _managedSource :: [ManagedFile] + , _managedData :: [ManagedFile] + } + +type ManagedFile = (FilePath, (MD5Digest, LogicalTimestamp)) + +-- | Mapping from C files to the corresponding .o files and their timestamps +type ObjectFiles = [(FilePath, (FilePath, LogicalTimestamp))] + +data GhcServer = OutProcess RpcServer + | InProcess RpcConversation ThreadId + +-- | Handles to the running code snippet, through which one can interact +-- with the snippet. +-- +-- Requirement: concurrent uses of @supplyStdin@ should be possible, +-- e.g., two threads that share a @RunActions@ should be able to provide +-- input concurrently without problems. (Currently this is ensured +-- by @supplyStdin@ writing to a channel.) +data RunActions a = RunActions { + -- | Wait for the code to output something or terminate + runWait :: IO (Either BSS.ByteString a) + -- | Send a UserInterrupt exception to the code + -- + -- A call to 'interrupt' after the snippet has terminated has no effect. + , interrupt :: IO () + -- | Make data available on the code's stdin + -- + -- A call to 'supplyStdin' after the snippet has terminated has no effect. + , supplyStdin :: BSS.ByteString -> IO () + -- | Force terminate the runaction + -- (The server will be useless after this -- for internal use only). + -- + -- Guranteed not to block. + , forceCancel :: IO () + } + +{------------------------------------------------------------------------------ + Accessors +------------------------------------------------------------------------------} + +ideLogicalTimestamp :: Accessor IdeIdleState LogicalTimestamp +ideComputed :: Accessor IdeIdleState (Strict Maybe Computed) +ideGhcOpts :: Accessor IdeIdleState [String] +ideRelativeIncludes :: Accessor IdeIdleState [FilePath] +ideGenerateCode :: Accessor IdeIdleState Bool +ideManagedFiles :: Accessor IdeIdleState ManagedFilesInternal +ideObjectFiles :: Accessor IdeIdleState ObjectFiles +ideBuildExeStatus :: Accessor IdeIdleState (Maybe ExitCode) +ideBuildDocStatus :: Accessor IdeIdleState (Maybe ExitCode) +ideBuildLicensesStatus :: Accessor IdeIdleState (Maybe ExitCode) +ideEnv :: Accessor IdeIdleState [(String, Maybe String)] +ideArgs :: Accessor IdeIdleState [String] +ideGhcServer :: Accessor IdeIdleState GhcServer +ideGhcVersion :: Accessor IdeIdleState GhcVersion +ideStdoutBufferMode :: Accessor IdeIdleState Public.RunBufferMode +ideStderrBufferMode :: Accessor IdeIdleState Public.RunBufferMode +ideBreakInfo :: Accessor IdeIdleState (Strict Maybe Public.BreakInfo) +ideTargets :: Accessor IdeIdleState Public.Targets +ideRtsOpts :: Accessor IdeIdleState [String] + +ideLogicalTimestamp = accessor _ideLogicalTimestamp $ \x s -> s { _ideLogicalTimestamp = x } +ideComputed = accessor _ideComputed $ \x s -> s { _ideComputed = x } +ideGhcOpts = accessor _ideGhcOpts $ \x s -> s { _ideGhcOpts = x } +ideRelativeIncludes = accessor _ideRelativeIncludes $ \x s -> s { _ideRelativeIncludes = x } +ideGenerateCode = accessor _ideGenerateCode $ \x s -> s { _ideGenerateCode = x } +ideManagedFiles = accessor _ideManagedFiles $ \x s -> s { _ideManagedFiles = x } +ideObjectFiles = accessor _ideObjectFiles $ \x s -> s { _ideObjectFiles = x } +ideBuildExeStatus = accessor _ideBuildExeStatus $ \x s -> s { _ideBuildExeStatus = x } +ideBuildDocStatus = accessor _ideBuildDocStatus $ \x s -> s { _ideBuildDocStatus = x } +ideBuildLicensesStatus = + accessor _ideBuildLicensesStatus $ \x s -> s { _ideBuildLicensesStatus = x } +ideEnv = accessor _ideEnv $ \x s -> s { _ideEnv = x } +ideArgs = accessor _ideArgs $ \x s -> s { _ideArgs = x } +ideGhcServer = accessor _ideGhcServer $ \x s -> s { _ideGhcServer = x } +ideGhcVersion = accessor _ideGhcVersion $ \x s -> s { _ideGhcVersion = x } +ideStdoutBufferMode = accessor _ideStdoutBufferMode $ \x s -> s { _ideStdoutBufferMode = x } +ideStderrBufferMode = accessor _ideStderrBufferMode $ \x s -> s { _ideStderrBufferMode = x } +ideBreakInfo = accessor _ideBreakInfo $ \x s -> s { _ideBreakInfo = x } +ideTargets = accessor _ideTargets $ \x s -> s { _ideTargets = x } +ideRtsOpts = accessor _ideRtsOpts $ \x s -> s { _ideRtsOpts = x } + +managedSource :: Accessor ManagedFilesInternal [ManagedFile] +managedData :: Accessor ManagedFilesInternal [ManagedFile] + +managedSource = accessor _managedSource $ \x s -> s { _managedSource = x } +managedData = accessor _managedData $ \x s -> s { _managedData = x } diff --git a/IdeSession/Strict/Container.hs b/IdeSession/Strict/Container.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/Container.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE TypeFamilies, FlexibleInstances, StandaloneDeriving #-} +module IdeSession.Strict.Container + ( StrictContainer(..) + , Strict(..) + -- * For convenience, we export the names of the lazy types too + , Maybe + , Map + , IntMap + , Trie + ) where + +import Control.Applicative +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.List as List +import Data.Trie (Trie) +import Data.Foldable as Foldable +import Data.Binary (Binary(..)) +import IdeSession.Util.PrettyVal + +class StrictContainer t where + data Strict (t :: * -> *) :: * -> * + force :: t a -> Strict t a + project :: Strict t a -> t a + +{------------------------------------------------------------------------------ + IntMap +------------------------------------------------------------------------------} + +instance StrictContainer IntMap where + newtype Strict IntMap v = StrictIntMap { toLazyIntMap :: IntMap v } + deriving Show + + force m = IntMap.foldl' (flip seq) () m `seq` StrictIntMap m + project = toLazyIntMap + +instance Binary v => Binary (Strict IntMap v) where + put = put . IntMap.toList . toLazyIntMap + get = (force . IntMap.fromList) <$> get + +instance PrettyVal v => PrettyVal (Strict IntMap v) where + prettyVal = prettyVal . toLazyIntMap + +{------------------------------------------------------------------------------ + Lists +------------------------------------------------------------------------------} + +instance StrictContainer [] where + newtype Strict [] a = StrictList { toLazyList :: [a] } + deriving (Show, Eq) + + force m = List.foldl' (flip seq) () m `seq` StrictList m + project = toLazyList + +-- TODO: we can do better than this if we cache the length of the list +instance Binary a => Binary (Strict [] a) where + put = put . toLazyList + get = force <$> get + +instance PrettyVal a => PrettyVal (Strict [] a) where + prettyVal = prettyVal . toLazyList + +{------------------------------------------------------------------------------ + Map +------------------------------------------------------------------------------} + +instance StrictContainer (Map k) where + newtype Strict (Map k) v = StrictMap { toLazyMap :: Map k v } + deriving (Show) + + force m = Map.foldl' (flip seq) () m `seq` StrictMap m + project = toLazyMap + +instance (Ord k, Binary k, Binary v) => Binary (Strict (Map k) v) where + put = put . Map.toList . toLazyMap + get = (force . Map.fromList) <$> get + +instance (PrettyVal k, PrettyVal v) => PrettyVal (Strict (Map k) v) where + prettyVal = prettyVal . toLazyMap + +{------------------------------------------------------------------------------ + Maybe +------------------------------------------------------------------------------} + +instance StrictContainer Maybe where + newtype Strict Maybe a = StrictMaybe { toLazyMaybe :: Maybe a } + deriving (Show) + + force Nothing = StrictMaybe Nothing + force (Just x) = x `seq` StrictMaybe $ Just x + project = toLazyMaybe + +instance Binary a => Binary (Strict Maybe a) where + put = put . toLazyMaybe + get = force <$> get + +deriving instance Eq a => Eq (Strict Maybe a) +deriving instance Ord a => Ord (Strict Maybe a) + +instance Functor (Strict Maybe) where + fmap f = force . fmap f . toLazyMaybe + +instance PrettyVal a => PrettyVal (Strict Maybe a) where + prettyVal = prettyVal . toLazyMaybe + +instance Applicative (Strict Maybe) where + pure = force . pure + -- We need 'force' here because we need to force the result of the + -- function application + f <*> a = force $ toLazyMaybe f <*> toLazyMaybe a + +instance Alternative (Strict Maybe) where + empty = StrictMaybe Nothing + a <|> b = StrictMaybe $ toLazyMaybe a <|> toLazyMaybe b + +{------------------------------------------------------------------------------ + Trie +------------------------------------------------------------------------------} + +instance StrictContainer Trie where + newtype Strict Trie a = StrictTrie { toLazyTrie :: Trie a } + deriving (Show) + + force m = Foldable.foldl (flip seq) () m `seq` StrictTrie m + project = toLazyTrie + +instance PrettyVal a => PrettyVal (Strict Trie a) where + prettyVal = prettyVal . toLazyTrie diff --git a/IdeSession/Strict/IORef.hs b/IdeSession/Strict/IORef.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/IORef.hs @@ -0,0 +1,28 @@ +-- IORefs that always evaluate their contents to WHNF +module IdeSession.Strict.IORef ( + StrictIORef -- Abstract + , newIORef + , readIORef + , writeIORef + , modifyIORef + ) where + +import Control.Applicative ((<$>)) +import Control.Exception (evaluate) +import Data.IORef (IORef) +import qualified Data.IORef as IORef + +newtype StrictIORef a = StrictIORef (IORef a) + +newIORef :: a -> IO (StrictIORef a) +newIORef x = StrictIORef <$> (evaluate x >>= IORef.newIORef) + +readIORef :: StrictIORef a -> IO a +readIORef (StrictIORef v) = IORef.readIORef v + +writeIORef :: StrictIORef a -> a -> IO () +writeIORef (StrictIORef v) x = evaluate x >>= IORef.writeIORef v + +-- base 4.6 exports modifyIORef' but 4.5 does not. +modifyIORef :: StrictIORef a -> (a -> a) -> IO () +modifyIORef v f = readIORef v >>= writeIORef v . f diff --git a/IdeSession/Strict/IntMap.hs b/IdeSession/Strict/IntMap.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/IntMap.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE TypeFamilies, FlexibleInstances #-} +-- | Wrapper around Data.IntMap that guarantees elements are evaluated when +-- the Map is. containers-0.5 provides this out of the box, but alas ghc 7.4 +-- is built against containers-0.4. +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +module IdeSession.Strict.IntMap ( + fromList + , toList + , lookup + , findWithDefault + , empty + , adjust + , insertWith + , map + , reverseLookup + , filter + , filterWithKey + , union + ) where + +import Prelude hiding (map, filter, lookup) +import Data.Tuple (swap) +import qualified Data.IntMap as IntMap +import qualified Data.List as List + +import IdeSession.Strict.Container + +lookup :: Int -> Strict IntMap v -> Maybe v +lookup i = IntMap.lookup i . toLazyIntMap + +findWithDefault :: v -> Int -> Strict IntMap v -> v +findWithDefault def i = IntMap.findWithDefault def i . toLazyIntMap + +fromList :: [(Int, v)] -> Strict IntMap v +fromList = force . IntMap.fromList + +toList :: Strict IntMap v -> [(Int, v)] +toList = IntMap.toList . toLazyIntMap + +empty :: Strict IntMap v +empty = StrictIntMap $ IntMap.empty + +-- We use alter because it gives us something to anchor a seq to +adjust :: forall v. (v -> v) -> Int -> Strict IntMap v -> Strict IntMap v +adjust f i = StrictIntMap . IntMap.alter aux i . toLazyIntMap + where + aux :: Maybe v -> Maybe v + aux Nothing = Nothing + aux (Just v) = let v' = f v in v' `seq` Just v' + +insertWith :: (v -> v -> v) -> Int -> v -> Strict IntMap v -> Strict IntMap v +insertWith f i v = StrictIntMap . IntMap.insertWith' f i v . toLazyIntMap + +map :: (a -> b) -> Strict IntMap a -> Strict IntMap b +map f = force . IntMap.map f . toLazyIntMap + +-- O(n) +reverseLookup :: Eq v => Strict IntMap v -> v -> Maybe Int +reverseLookup m v = List.lookup v $ List.map swap $ toList m + +filter :: (v -> Bool) -> Strict IntMap v -> Strict IntMap v +filter p = StrictIntMap . IntMap.filter p . toLazyIntMap + +filterWithKey :: (Int -> v -> Bool) -> Strict IntMap v -> Strict IntMap v +filterWithKey p = StrictIntMap . IntMap.filterWithKey p . toLazyIntMap + +union :: Strict IntMap v -> Strict IntMap v -> Strict IntMap v +union a b = StrictIntMap $ IntMap.union (toLazyIntMap a) (toLazyIntMap b) diff --git a/IdeSession/Strict/IntervalMap.hs b/IdeSession/Strict/IntervalMap.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/IntervalMap.hs @@ -0,0 +1,62 @@ +module IdeSession.Strict.IntervalMap ( + StrictIntervalMap + , dominators + , fromList + , toList + , empty + , insert + -- * Re-exports + , Interval(..) + ) where + +import Data.IntervalMap.FingerTree (Interval(..), IntervalMap) +import qualified Data.IntervalMap.FingerTree as IntervalMap +import Text.Show.Pretty + +{- + We maintain an interval spanning the entire map, in order to support a toList + operation. +-} + +data StrictIntervalMap v a = StrictIntervalMap { + toLazyIntervalMap :: !(IntervalMap v a) + , maxInterval :: !(Maybe (Interval v)) + } + +instance (Ord v, Show v, Show a) => Show (StrictIntervalMap v a) where + show m = "fromList " ++ show (toList m) + +instance (Ord v, PrettyVal v, PrettyVal a) => PrettyVal (StrictIntervalMap v a) where + prettyVal m = Con "fromList" [prettyVal . map flattenIntervals . toList $ m] + where + flattenIntervals :: (Interval v, a) -> ((v, v), a) + flattenIntervals (Interval lo hi, a) = ((lo, hi), a) + +unionInterval :: Ord v => Interval v -> Maybe (Interval v) -> Maybe (Interval v) +unionInterval i@(Interval low high) Nothing = + low `seq` high `seq` Just i +unionInterval (Interval low1 high1) (Just (Interval low2 high2)) = + let low = min low1 low2 + high = max high1 high2 + in low `seq` high `seq` Just (Interval low high) + +dominators :: Ord v => Interval v -> StrictIntervalMap v a -> [(Interval v, a)] +dominators i = IntervalMap.dominators i . toLazyIntervalMap + +empty :: Ord v => StrictIntervalMap v a +empty = StrictIntervalMap IntervalMap.empty Nothing + +insert :: Ord v => Interval v -> a -> StrictIntervalMap v a -> StrictIntervalMap v a +insert i a m = + a `seq` StrictIntervalMap { + toLazyIntervalMap = IntervalMap.insert i a $ toLazyIntervalMap m + , maxInterval = unionInterval i $ maxInterval m + } + +fromList :: Ord v => [(Interval v, a)] -> StrictIntervalMap v a +fromList = foldr (\(i, a) m -> insert i a m) empty + +toList :: Ord v => StrictIntervalMap v a -> [(Interval v, a)] +toList m = case maxInterval m of + Nothing -> [] + Just i -> IntervalMap.intersections i (toLazyIntervalMap m) diff --git a/IdeSession/Strict/List.hs b/IdeSession/Strict/List.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/List.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +-- | Strict lists +module IdeSession.Strict.List ( + nil + , cons + , singleton + , map + , all + , any + , reverse + , (++) + , elem + , (\\) + ) where + +import Prelude hiding (map, all, any, reverse, (++), elem) +import qualified Data.List as List + +import IdeSession.Strict.Container + +nil :: Strict [] a +nil = StrictList [] + +cons :: a -> Strict [] a -> Strict [] a +cons x xs = x `seq` StrictList (x : toLazyList xs) + +singleton :: a -> Strict [] a +singleton x = x `seq` StrictList [x] + +map :: (a -> b) -> Strict [] a -> Strict [] b +map f = force . List.map f . toLazyList + +all :: (a -> Bool) -> Strict [] a -> Bool +all p = List.all p . toLazyList + +any :: (a -> Bool) -> Strict [] a -> Bool +any p = List.any p . toLazyList + +elem :: Eq a => a -> Strict [] a -> Bool +elem x = List.elem x . toLazyList + +reverse :: Strict [] a -> Strict [] a +reverse = StrictList . List.reverse . toLazyList + +(++) :: Strict [] a -> Strict [] a -> Strict [] a +xs ++ ys = StrictList $ toLazyList xs List.++ toLazyList ys + +(\\) :: Eq a => Strict [] a -> Strict [] a -> Strict [] a +xs \\ ys = StrictList $ toLazyList xs List.\\ toLazyList ys diff --git a/IdeSession/Strict/MVar.hs b/IdeSession/Strict/MVar.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/MVar.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | MVar that always evaluates its argument to WHNF +module IdeSession.Strict.MVar ( + StrictMVar -- Abstract + , newEmptyMVar + , newMVar + , takeMVar + , putMVar + , readMVar + , swapMVar + , tryTakeMVar + , tryPutMVar + , isEmptyMVar + , withMVar + , modifyMVar_ + , modifyMVar + ) where + +import Control.Concurrent.MVar (MVar) +import qualified Control.Concurrent.MVar as MVar +import Control.Applicative ((<$>)) +import Control.Exception (evaluate) +import Control.Monad ((>=>)) + +newtype StrictMVar a = StrictMVar (MVar a) + +newEmptyMVar :: IO (StrictMVar a) +newEmptyMVar = StrictMVar <$> MVar.newEmptyMVar + +newMVar :: a -> IO (StrictMVar a) +newMVar x = StrictMVar <$> (evaluate x >>= MVar.newMVar) + +takeMVar :: StrictMVar a -> IO a +takeMVar (StrictMVar v) = MVar.takeMVar v + +putMVar :: StrictMVar a -> a -> IO () +putMVar (StrictMVar v) x = evaluate x >>= MVar.putMVar v + +readMVar :: StrictMVar a -> IO a +readMVar (StrictMVar v) = MVar.readMVar v + +swapMVar :: StrictMVar a -> a -> IO a +swapMVar (StrictMVar v) x = evaluate x >>= MVar.swapMVar v + +tryTakeMVar :: StrictMVar a -> IO (Maybe a) +tryTakeMVar (StrictMVar v) = MVar.tryTakeMVar v + +tryPutMVar :: StrictMVar a -> a -> IO Bool +tryPutMVar (StrictMVar v) x = evaluate x >>= MVar.tryPutMVar v + +isEmptyMVar :: StrictMVar a -> IO Bool +isEmptyMVar (StrictMVar v) = MVar.isEmptyMVar v + +withMVar :: StrictMVar a -> (a -> IO b) -> IO b +withMVar (StrictMVar v) f = MVar.withMVar v f + +modifyMVar_ :: StrictMVar a -> (a -> IO a) -> IO () +modifyMVar_ (StrictMVar v) f = MVar.modifyMVar_ v (f >=> evaluate) + +modifyMVar :: forall a b. StrictMVar a -> (a -> IO (a, b)) -> IO b +modifyMVar (StrictMVar v) f = MVar.modifyMVar v aux + where + aux :: a -> IO (a, b) + aux x = do (a, b) <- f x + a' <- evaluate a + return (a', b) diff --git a/IdeSession/Strict/Map.hs b/IdeSession/Strict/Map.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/Map.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +-- | Wrapper around Data.Map that guarantees elements are evaluated when +-- the Map is. containers-0.5 provides this out of the box, but alas ghc 7.4 +-- is built against containers-0.4. +module IdeSession.Strict.Map ( + toList + , fromList + , map + , mapWithKey + , mapKeys + , empty + , insert + , union + , unions + , filterWithKey + , lookup + , findWithDefault + , keysSet + , (\\) + , alter + , adjust + , member + , (!) + , keys + , elems + , delete + , accessor + , accessorDefault + ) where + +import Prelude hiding (map, lookup) +import Data.Set (Set) +import qualified Data.Map as Map +import Data.Accessor (Accessor) +import qualified Data.Accessor as Acc +import qualified Data.List as List + +import IdeSession.Strict.Container + +toList :: Strict (Map k) v -> [(k, v)] +toList = Map.toList . toLazyMap + +fromList :: Ord k => [(k, v)] -> Strict (Map k) v +fromList = force . Map.fromList + +map :: (a -> b) -> Strict (Map k) a -> Strict (Map k) b +map f = force . Map.map f . toLazyMap + +mapWithKey :: (k -> a -> b) -> Strict (Map k) a -> Strict (Map k) b +mapWithKey f = force . Map.mapWithKey f . toLazyMap + +mapKeys :: Ord k' => (k -> k') -> Strict (Map k) v -> Strict (Map k') v +-- Maps are already strict in keys +mapKeys f = StrictMap . Map.mapKeys f . toLazyMap + +empty :: Strict (Map k) v +empty = StrictMap Map.empty + +insert :: Ord k => k -> v -> Strict (Map k) v -> Strict (Map k) v +insert k v = StrictMap . Map.insertWith' const k v . toLazyMap + +-- | Left biased union +union :: Ord k => Strict (Map k) v -> Strict (Map k) v -> Strict (Map k) v +union a b = StrictMap $ Map.union (toLazyMap a) (toLazyMap b) + +unions :: Ord k => [Strict (Map k) v] -> Strict (Map k) v +unions = StrictMap . Map.unions . List.map toLazyMap + +filterWithKey :: Ord k => (k -> v -> Bool) -> Strict (Map k) v -> Strict (Map k) v +filterWithKey p = StrictMap . Map.filterWithKey p . toLazyMap + +keysSet :: Strict (Map k) v -> Set k +keysSet = Map.keysSet . toLazyMap + +lookup :: Ord k => k -> Strict (Map k) v -> Maybe v +lookup k = Map.lookup k . toLazyMap + +findWithDefault :: Ord k => v -> k -> Strict (Map k) v -> v +findWithDefault d k = Map.findWithDefault d k . toLazyMap + +(\\) :: Ord k => Strict (Map k) a -> Strict (Map k) b -> Strict (Map k) a +(\\) a b = StrictMap $ (Map.\\) (toLazyMap a) (toLazyMap b) + +alter :: forall k a. Ord k + => (Maybe a -> Maybe a) -> k -> Strict (Map k) a -> Strict (Map k) a +alter f k = StrictMap . Map.alter aux k . toLazyMap + where + aux :: Maybe a -> Maybe a + aux ma = case f ma of + Nothing -> Nothing + Just a -> a `seq` Just a + +-- We use alter because it gives us something to anchor a seq to +adjust :: forall k v. Ord k => (v -> v) -> k -> Strict (Map k) v -> Strict (Map k) v +adjust f i = StrictMap . Map.alter aux i . toLazyMap + where + aux :: Maybe v -> Maybe v + aux Nothing = Nothing + aux (Just v) = let v' = f v in v' `seq` Just v' + +member :: Ord k => k -> Strict (Map k) v -> Bool +member k = Map.member k . toLazyMap + +(!) :: Ord k => Strict (Map k) v -> k -> v +(!) = (Map.!) . toLazyMap + +keys :: Strict (Map k) a -> [k] +keys = Map.keys . toLazyMap + +elems :: Strict (Map k) a -> [a] +elems = Map.elems . toLazyMap + +delete :: Ord k => k -> Strict (Map k) a -> Strict (Map k) a +delete k = StrictMap . Map.delete k . toLazyMap + +accessor :: Ord k => k -> Accessor (Strict (Map k) a) (Maybe a) +accessor key = Acc.accessor (lookup key) (\mval mp -> case mval of + Just val -> insert key val mp + Nothing -> delete key mp) + +accessorDefault :: Ord k => v -> k -> Accessor (Strict (Map k) v) v +accessorDefault d k = Acc.accessor (findWithDefault d k) (insert k) diff --git a/IdeSession/Strict/Maybe.hs b/IdeSession/Strict/Maybe.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/Maybe.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell, DeriveFunctor #-} +-- | Version of maybe that is strict in its argument +module IdeSession.Strict.Maybe ( + nothing + , just + , maybe + , fromMaybe + ) where + +import Prelude hiding (maybe) +import IdeSession.Strict.Container +import qualified Data.Maybe as Maybe + +nothing :: Strict Maybe a +nothing = force $ Nothing + +just :: a -> Strict Maybe a +just = force . Just + +maybe :: b -> (a -> b) -> Strict Maybe a -> b +maybe x f = Maybe.maybe x f . toLazyMaybe + +fromMaybe :: a -> Strict Maybe a -> a +fromMaybe def = Maybe.fromMaybe def . toLazyMaybe diff --git a/IdeSession/Strict/StateT.hs b/IdeSession/Strict/StateT.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/StateT.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +-- | Version on StateT which evaluates the state strictly at every step +module IdeSession.Strict.StateT ( + -- * Transformer + StrictStateT(..) + , modify + , evalStateT + , execStateT + -- * As base monad + , StrictState + , runState + , evalState + , execState + ) where + +import Control.Applicative +import Control.Monad.State.Class +import Control.Monad.Trans.Class +import Data.Functor.Identity + +newtype StrictStateT s m a = StrictStateT { runStateT :: s -> m (a, s) } + +instance Monad m => Applicative (StrictStateT s m) where + pure = return + f <*> x = do f' <- f ; x' <- x ; return (f' x') + +instance Monad m => Monad (StrictStateT s m) where + return a = StrictStateT $ \s -> return (a, s) + x >>= f = StrictStateT $ \s -> do (a, s') <- runStateT x s + (b, s'') <- runStateT (f a) s' + return (b, s'') + +instance Monad m => Functor (StrictStateT s m) where + f `fmap` m = m >>= return . f + +instance Monad m => MonadState s (StrictStateT s m) where + get = StrictStateT $ \s -> return (s, s) + put s = StrictStateT $ \_ -> s `seq` return ((), s) + state f = StrictStateT $ \s -> do let (a, s') = f s + s' `seq` return (a, s') + +instance MonadTrans (StrictStateT s) where + lift m = StrictStateT $ \s -> do a <- m + return (a, s) + +evalStateT :: Monad m => StrictStateT s m a -> s -> m a +evalStateT m s = do (a, _) <- runStateT m s ; return a + +execStateT :: Monad m => StrictStateT s m a -> s -> m s +execStateT m s = do (_, s') <- runStateT m s ; return s' + +{------------------------------------------------------------------------------ + As base monad +------------------------------------------------------------------------------} + +type StrictState s = StrictStateT s Identity + +runState :: StrictState s a -> s -> (a, s) +runState m s = runIdentity $ runStateT m s + +evalState :: StrictState s a -> s -> a +evalState m = fst . runState m + +execState :: StrictState s a -> s -> s +execState m = snd . runState m diff --git a/IdeSession/Strict/Trie.hs b/IdeSession/Strict/Trie.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Strict/Trie.hs @@ -0,0 +1,27 @@ +module IdeSession.Strict.Trie ( + empty + , submap + , elems + , fromListWith + , toList + ) where + +import Data.ByteString (ByteString) +import qualified Data.Trie as Trie +import qualified Data.Trie.Convenience as Trie +import IdeSession.Strict.Container + +empty :: Strict Trie a +empty = StrictTrie $ Trie.empty + +submap :: ByteString -> Strict Trie a -> Strict Trie a +submap bs = StrictTrie . Trie.submap bs . toLazyTrie + +elems :: Strict Trie a -> [a] +elems = Trie.elems . toLazyTrie + +fromListWith :: (a -> a -> a) -> [(ByteString, a)] -> Strict Trie a +fromListWith f = force . Trie.fromListWith f + +toList :: Strict Trie a -> [(ByteString, a)] +toList = Trie.toList . toLazyTrie diff --git a/IdeSession/Types/Private.hs b/IdeSession/Types/Private.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Types/Private.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric #-} +-- | The private types +module IdeSession.Types.Private ( + -- * Types without a public counterpart + FilePathPtr(..) + , IdPropPtr(..) + , UseSites + -- * Types with a public counterpart + , Public.IdNameSpace(..) + , IdInfo(..) + , IdProp(..) + , IdScope(..) + , SourceSpan(..) + , EitherSpan(..) + , SourceError(..) + , Public.SourceErrorKind(..) + , Public.ModuleName + , ModuleId(..) + , PackageId(..) + , IdList + , IdMap(..) + , ExpMap(..) + , SpanInfo(..) + , ImportEntities(..) + , Import(..) + , RunResult(..) + , BreakInfo(..) + -- * Cache + , ExplicitSharingCache(..) + , unionCache + -- * Util + , mkIdMap + , mkExpMap + , dominators + ) where + +import Prelude hiding (span, mod) +import Data.Text (Text) +import Data.ByteString (ByteString) +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (first) +import Data.Binary (Binary(..), getWord8, putWord8) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + +import qualified IdeSession.Types.Public as Public +import IdeSession.Strict.Container +import IdeSession.Strict.IntervalMap (StrictIntervalMap, Interval(..)) +import qualified IdeSession.Strict.IntervalMap as IntervalMap +import qualified IdeSession.Strict.IntMap as IntMap +import IdeSession.Util.PrettyVal + +newtype FilePathPtr = FilePathPtr { filePathPtr :: Int } + deriving (Eq, Ord, Show, Generic) + +newtype IdPropPtr = IdPropPtr { idPropPtr :: Int } + deriving (Eq, Ord, Show, Generic) + +data IdInfo = IdInfo { + idProp :: {-# UNPACK #-} !IdPropPtr + , idScope :: !IdScope + } + deriving (Show, Typeable, Generic) + +data IdProp = IdProp { + idName :: !Text + , idSpace :: !Public.IdNameSpace + , idType :: !(Strict Maybe Public.Type) + , idDefinedIn :: {-# UNPACK #-} !ModuleId + , idDefSpan :: !EitherSpan + , idHomeModule :: !(Strict Maybe ModuleId) + } + deriving (Show, Generic) + +data IdScope = + -- | This is a binding occurrence (@f x = ..@, @\x -> ..@, etc.) + Binder + -- | Defined within this module + | Local + -- | Imported from a different module + | Imported { + idImportedFrom :: {-# UNPACK #-} !ModuleId + , idImportSpan :: !EitherSpan + -- | Qualifier used for the import + -- + -- > IMPORTED AS idImportQual + -- > import Data.List "" + -- > import qualified Data.List "Data.List." + -- > import qualified Data.List as L "L." + , idImportQual :: !Text + } + -- | Wired into the compiler (@()@, @True@, etc.) + | WiredIn + deriving (Show, Generic) + +data SourceSpan = SourceSpan + { spanFilePath :: {-# UNPACK #-} !FilePathPtr + , spanFromLine :: {-# UNPACK #-} !Int + , spanFromColumn :: {-# UNPACK #-} !Int + , spanToLine :: {-# UNPACK #-} !Int + , spanToColumn :: {-# UNPACK #-} !Int + } + deriving (Eq, Ord, Show, Generic) + +data EitherSpan = + ProperSpan {-# UNPACK #-} !SourceSpan + | TextSpan !Text + deriving (Show, Generic) + +data SourceError = SourceError + { errorKind :: !Public.SourceErrorKind + , errorSpan :: !EitherSpan + , errorMsg :: !Text + } + deriving (Show, Generic) + +data ModuleId = ModuleId + { moduleName :: !Public.ModuleName + , modulePackage :: {-# UNPACK #-} !PackageId + } + deriving (Show, Eq, Generic) + +data PackageId = PackageId + { packageName :: !Text + , packageVersion :: !(Strict Maybe Text) + , packageKey :: !Text + } + deriving (Show, Eq, Ord, Generic) + +-- | Used before we convert it to an IdMap +type IdList = [(SourceSpan, SpanInfo)] + +data SpanInfo = + SpanId IdInfo + | SpanQQ IdInfo + -- We use 'SpanInSplice' for prioritization only (see 'internalGetSpanInfo'). + -- It gets translated to 'Public.SpanId' + | SpanInSplice IdInfo + deriving (Show, Generic) + +newtype IdMap = IdMap { idMapToMap :: StrictIntervalMap (FilePathPtr, Int, Int) SpanInfo } + deriving (Show, Generic) + +newtype ExpMap = ExpMap { expMapToMap :: StrictIntervalMap (FilePathPtr, Int, Int) Text } + deriving (Show, Generic) + +type UseSites = Strict (Map IdPropPtr) [SourceSpan] + +data ImportEntities = + ImportOnly !(Strict [] Text) + | ImportHiding !(Strict [] Text) + | ImportAll + deriving (Show, Eq, Generic) + +data Import = Import { + importModule :: !ModuleId + -- | Used only for ghc's PackageImports extension + , importPackage :: !(Strict Maybe Text) + , importQualified :: !Bool + , importImplicit :: !Bool + , importAs :: !(Strict Maybe Public.ModuleName) + , importEntities :: !ImportEntities + } + deriving (Show, Eq, Generic) + +-- | The outcome of running code +data RunResult = + -- | The code terminated okay + RunOk + -- | The code threw an exception + | RunProgException String + -- | GHC itself threw an exception when we tried to run the code + | RunGhcException String + -- | Execution was paused because of a breakpoint + | RunBreak BreakInfo + deriving (Typeable, Show, Generic) + +-- | Information about a triggered breakpoint +data BreakInfo = BreakInfo { + breakInfoModule :: Public.ModuleName + , breakInfoSpan :: SourceSpan + , breakInfoResultType :: Public.Type + , breakInfoVariableEnv :: Public.VariableEnv + } + deriving (Typeable, Show, Generic) + +{------------------------------------------------------------------------------ + Cache +------------------------------------------------------------------------------} + +-- TODO: Since the ExplicitSharingCache contains internal types, resolving +-- references to the cache means we lose implicit sharing because we need +-- to translate on every lookup. To avoid this, we'd have to introduce two +-- versions of the cache and translate the entire cache first. +data ExplicitSharingCache = ExplicitSharingCache { + filePathCache :: !(Strict IntMap ByteString) + , idPropCache :: !(Strict IntMap IdProp) + } + deriving (Show, Generic) + +unionCache :: ExplicitSharingCache -> ExplicitSharingCache -> ExplicitSharingCache +unionCache a b = ExplicitSharingCache { + filePathCache = IntMap.union (filePathCache a) (filePathCache b) + , idPropCache = IntMap.union (idPropCache a) (idPropCache b) + } + +{------------------------------------------------------------------------------ + Binary instances +------------------------------------------------------------------------------} + +instance Binary FilePathPtr where + put = put . filePathPtr + get = FilePathPtr <$> get + +instance Binary SourceSpan where + put SourceSpan{..} = do + put spanFilePath + put spanFromLine + put spanFromColumn + put spanToLine + put spanToColumn + get = SourceSpan <$> get <*> get <*> get <*> get <*> get + +instance Binary EitherSpan where + put (ProperSpan span) = putWord8 0 >> put span + put (TextSpan text) = putWord8 1 >> put text + + get = do + header <- getWord8 + case header of + 0 -> ProperSpan <$> get + 1 -> TextSpan <$> get + _ -> fail "EitherSpan.get: invalid header" + +instance Binary SourceError where + put SourceError{..} = do + put errorKind + put errorSpan + put errorMsg + + get = SourceError <$> get <*> get <*> get + +instance Binary IdInfo where + put IdInfo{..} = put idProp >> put idScope + get = IdInfo <$> get <*> get + +instance Binary IdScope where + put Binder = putWord8 0 + put Local = do putWord8 1 + put Imported{..} = do putWord8 2 + put idImportedFrom + put idImportSpan + put idImportQual + put WiredIn = putWord8 3 + + get = do + header <- getWord8 + case header of + 0 -> return Binder + 1 -> return Local + 2 -> Imported <$> get <*> get <*> get + 3 -> return WiredIn + _ -> fail "IdScope.get: invalid header" + +instance Binary IdPropPtr where + put = put . idPropPtr + get = IdPropPtr <$> get + +instance Binary ModuleId where + put ModuleId{..} = put moduleName >> put modulePackage + get = ModuleId <$> get <*> get + +instance Binary PackageId where + put PackageId{..} = do + put packageName + put packageVersion + put packageKey + get = PackageId <$> get <*> get <*> get + +instance Binary IdProp where + put IdProp{..} = do + put idName + put idSpace + put idType + put idDefinedIn + put idDefSpan + put idHomeModule + + get = IdProp <$> get <*> get <*> get <*> get <*> get <*> get + +{- +instance Binary IdMap where + put = put . idMapToMap + get = IdMap <$> get +-} + +instance Binary ImportEntities where + put (ImportOnly names) = putWord8 0 >> put names + put (ImportHiding names) = putWord8 1 >> put names + put ImportAll = putWord8 2 + + get = do + header <- getWord8 + case header of + 0 -> ImportOnly <$> get + 1 -> ImportHiding <$> get + 2 -> return ImportAll + _ -> fail "ImportEntities.get: invalid header" + +instance Binary Import where + put Import{..} = do + put importModule + put importPackage + put importQualified + put importImplicit + put importAs + put importEntities + + get = Import <$> get <*> get <*> get <*> get <*> get <*> get + +instance Binary ExplicitSharingCache where + put ExplicitSharingCache{..} = do + put filePathCache + put idPropCache + + get = ExplicitSharingCache <$> get <*> get + +instance Binary SpanInfo where + put (SpanId idInfo) = putWord8 0 >> put idInfo + put (SpanQQ idInfo) = putWord8 1 >> put idInfo + put (SpanInSplice idInfo) = putWord8 2 >> put idInfo + + get = do + header <- getWord8 + case header of + 0 -> SpanId <$> get + 1 -> SpanQQ <$> get + 2 -> SpanInSplice <$> get + _ -> fail "SpanInfo.get: invalid header" + +instance Binary RunResult where + put RunOk = putWord8 0 + put (RunProgException str) = putWord8 1 >> put str + put (RunGhcException str) = putWord8 2 >> put str + put (RunBreak info) = putWord8 3 >> put info + + get = do + header <- getWord8 + case header of + 0 -> return RunOk + 1 -> RunProgException <$> get + 2 -> RunGhcException <$> get + 3 -> RunBreak <$> get + _ -> fail "RunResult.get: invalid header" + +instance Binary BreakInfo where + put (BreakInfo{..}) = do + put breakInfoModule + put breakInfoSpan + put breakInfoResultType + put breakInfoVariableEnv + + get = BreakInfo <$> get <*> get <*> get <*> get + +{------------------------------------------------------------------------------ + PrettyVal instances (these rely on Generics) +------------------------------------------------------------------------------} + +instance PrettyVal FilePathPtr +instance PrettyVal IdPropPtr +instance PrettyVal IdInfo +instance PrettyVal IdProp +instance PrettyVal IdScope +instance PrettyVal SourceSpan +instance PrettyVal EitherSpan +instance PrettyVal SourceError +instance PrettyVal ModuleId +instance PrettyVal PackageId +instance PrettyVal SpanInfo +instance PrettyVal IdMap +instance PrettyVal ExpMap +instance PrettyVal ImportEntities +instance PrettyVal Import +instance PrettyVal RunResult +instance PrettyVal BreakInfo +instance PrettyVal ExplicitSharingCache + +{------------------------------------------------------------------------------ + Util +------------------------------------------------------------------------------} + +mkIdMap :: IdList -> IdMap +mkIdMap = IdMap . IntervalMap.fromList . map (first spanToInterval) + +mkExpMap :: [(SourceSpan, Text)] -> ExpMap +mkExpMap = ExpMap . IntervalMap.fromList . map (first spanToInterval) + +dominators :: SourceSpan -> StrictIntervalMap (FilePathPtr, Int, Int) a -> [(SourceSpan, a)] +dominators span ivalmap = + map (\(ival, idInfo) -> (intervalToSpan ival, idInfo)) + (IntervalMap.dominators (spanToInterval span) ivalmap) + +spanToInterval :: SourceSpan -> Interval (FilePathPtr, Int, Int) +spanToInterval SourceSpan{..} = + Interval (spanFilePath, spanFromLine, spanFromColumn) + (spanFilePath, spanToLine, spanToColumn) + +intervalToSpan :: Interval (FilePathPtr, Int, Int) -> SourceSpan +intervalToSpan (Interval (spanFilePath, spanFromLine, spanFromColumn) + (_, spanToLine, spanToColumn)) = + SourceSpan{..} diff --git a/IdeSession/Types/Progress.hs b/IdeSession/Types/Progress.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Types/Progress.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveGeneric #-} +module IdeSession.Types.Progress ( + Progress(..) + ) where + +import Control.Applicative ((<$>), (<*>), (<|>)) +import Data.Binary (Binary(..)) +import Data.Text (Text) +import Data.Maybe (fromJust) +import GHC.Generics (Generic) +import qualified Data.Text as Text +import Text.Show.Pretty (PrettyVal) + +import IdeSession.Util () -- instance Binary Text + +-- | This type represents intermediate progress information during compilation. +data Progress = Progress { + -- | The current step number + -- + -- When these Progress messages are generated from progress updates from + -- ghc, it is entirely possible that we might get step 4/26, 16/26, 3/26; + -- the steps may not be continuous, might even be out of order, and may + -- not finish at X/X. + progressStep :: Int + + -- | The total number of steps + , progressNumSteps :: Int + + -- | The parsed message. For instance, in the case of progress messages + -- during compilation, 'progressOrigMsg' might be + -- + -- > [1 of 2] Compiling M (some/path/to/file.hs, some/other/path/to/file.o) + -- + -- while 'progressMsg' will just be 'Compiling M' + , progressParsedMsg :: Maybe Text + + -- | The full original message (see 'progressMsg') + , progressOrigMsg :: Maybe Text + } + deriving (Eq, Ord, Generic) + +instance PrettyVal Progress + +instance Binary Progress where + put (Progress {..}) = do put progressStep + put progressNumSteps + put progressParsedMsg + put progressOrigMsg + get = Progress <$> get <*> get <*> get <*> get + +instance Show Progress where + show (Progress{..}) = + "[" + ++ show progressStep + ++ " of " + ++ show progressNumSteps + ++ "]" + ++ fromJust (pad progressParsedMsg <|> pad progressOrigMsg <|> Just "") + where + pad :: Maybe Text -> Maybe String + pad = fmap $ \t -> " " ++ Text.unpack t diff --git a/IdeSession/Types/Public.hs b/IdeSession/Types/Public.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Types/Public.hs @@ -0,0 +1,571 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-} +-- | The public types +module IdeSession.Types.Public ( + -- * Types + IdNameSpace(..) + , Type + , Name + , IdInfo(..) + , IdProp(..) + , IdScope(..) + , SourceSpan(..) + , EitherSpan(..) + , SourceError(..) + , SourceErrorKind(..) + , ModuleName + , ModuleId(..) + , PackageId(..) +-- , IdMap(..) +-- , LoadedModules + , ImportEntities(..) + , Import(..) + , SpanInfo(..) + , RunBufferMode(..) + , RunResult(..) + , BreakInfo(..) + , Value + , VariableEnv + , Targets(..) + -- * Util + , idInfoQN +--, idInfoAtLocation + , haddockLink + ) where + +import Prelude hiding (span) +import Control.Applicative ((<$>), (<*>)) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Binary (Binary(..), getWord8, putWord8) +import Data.Aeson.TH (deriveJSON, defaultOptions) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + +import IdeSession.Util () -- Binary instance for Text +import IdeSession.Util.PrettyVal + +{------------------------------------------------------------------------------ + Types +------------------------------------------------------------------------------} + +-- | Identifiers in Haskell are drawn from a number of different name spaces +data IdNameSpace = + VarName -- ^ Variables, including real data constructors + | DataName -- ^ Source data constructors + | TvName -- ^ Type variables + | TcClsName -- ^ Type constructors and classes + deriving (Show, Eq, Generic) + +-- | Information about identifiers +data IdInfo = IdInfo { + idProp :: {-# UNPACK #-} !IdProp + , idScope :: !IdScope + } + deriving (Eq, Generic) + +-- | Variable name +type Name = Text + +-- | For now we represent types in pretty-printed form +type Type = Text + +-- | Identifier info that is independent of the usage site +data IdProp = IdProp { + -- | The base name of the identifer at this location. Module prefix + -- is not included. + idName :: !Name + -- | Namespace this identifier is drawn from + , idSpace :: !IdNameSpace + -- | The type + -- We don't always know this; in particular, we don't know kinds because + -- the type checker does not give us LSigs for top-level annotations) + , idType :: !(Maybe Type) + -- | Module the identifier was defined in + , idDefinedIn :: {-# UNPACK #-} !ModuleId + -- | Where in the module was it defined (not always known) + , idDefSpan :: !EitherSpan + -- | Haddock home module + , idHomeModule :: !(Maybe ModuleId) + } + deriving (Eq, Generic) + +-- TODO: Ideally, we would have +-- 1. SourceSpan for Local rather than EitherSpan +-- 2. SourceSpan for idImportSpan +-- 3. Have a idImportedFromPackage, but unfortunately ghc doesn't give us +-- this information (it's marked as a TODO in RdrName.lhs) +data IdScope = + -- | This is a binding occurrence (@f x = ..@, @\x -> ..@, etc.) + Binder + -- | Defined within this module + | Local + -- | Imported from a different module + | Imported { + idImportedFrom :: {-# UNPACK #-} !ModuleId + , idImportSpan :: !EitherSpan + -- | Qualifier used for the import + -- + -- > IMPORTED AS idImportQual + -- > import Data.List "" + -- > import qualified Data.List "Data.List." + -- > import qualified Data.List as L "L." + , idImportQual :: !Text + } + -- | Wired into the compiler (@()@, @True@, etc.) + | WiredIn + deriving (Eq, Generic) + +data SourceSpan = SourceSpan + { spanFilePath :: !FilePath + , spanFromLine :: {-# UNPACK #-} !Int + , spanFromColumn :: {-# UNPACK #-} !Int + , spanToLine :: {-# UNPACK #-} !Int + , spanToColumn :: {-# UNPACK #-} !Int + } + deriving (Eq, Ord, Generic) + +data EitherSpan = + ProperSpan {-# UNPACK #-} !SourceSpan + | TextSpan !Text + deriving (Eq, Generic) + +-- | An error or warning in a source module. +-- +-- Most errors are associated with a span of text, but some have only a +-- location point. +data SourceError = SourceError + { errorKind :: !SourceErrorKind + , errorSpan :: !EitherSpan + , errorMsg :: !Text + } + deriving (Show, Eq, Generic) + +-- | Severity of an error. +data SourceErrorKind = KindError | KindWarning | KindServerDied + deriving (Show, Eq, Generic) + +type ModuleName = Text + +data ModuleId = ModuleId + { moduleName :: !ModuleName + , modulePackage :: {-# UNPACK #-} !PackageId + } + deriving (Eq, Ord, Generic) + +-- | A package ID in ide-backend consists of a human-readable package name +-- and version (what Cabal calls a source ID) along with ghc's internal +-- package key (primarily for internal use). +data PackageId = PackageId + { packageName :: !Text + , packageVersion :: !(Maybe Text) + , packageKey :: !Text + } + deriving (Eq, Ord, Generic) + +{- +newtype IdMap = IdMap { idMapToMap :: Map SourceSpan IdInfo } + +type LoadedModules = Map ModuleName IdMap +-} + +data ImportEntities = + ImportOnly ![Text] + | ImportHiding ![Text] + | ImportAll + deriving (Show, Eq, Ord, Generic) + +data Import = Import { + importModule :: !ModuleId + -- | Used only for ghc's PackageImports extension + , importPackage :: !(Maybe Text) + , importQualified :: !Bool + , importImplicit :: !Bool + , importAs :: !(Maybe ModuleName) + , importEntities :: !ImportEntities + } + deriving (Show, Eq, Ord, Generic) + +-- | Returned then the IDE asks "what's at this particular location?" +data SpanInfo = + -- | Identifier + SpanId IdInfo + -- | Quasi-quote. The 'IdInfo' field gives the quasi-quoter + | SpanQQ IdInfo + deriving (Generic) + +-- | Buffer modes for running code +-- +-- Note that 'NoBuffering' means that something like 'putStrLn' will do a +-- syscall per character, and each of these characters will be read and sent +-- back to the client. This results in a large overhead. +-- +-- When using 'LineBuffering' or 'BlockBuffering', 'runWait' will not report +-- any output from the snippet until it outputs a linebreak/fills the buffer, +-- respectively (or does an explicit flush). However, you can specify a timeout +-- in addition to the buffering mode; if you set this to @Just n@, the buffer +-- will be flushed every @n@ microseconds. +-- +-- NOTE: This is duplicated in the IdeBackendRTS (defined in IdeSession) +data RunBufferMode = + RunNoBuffering + | RunLineBuffering { runBufferTimeout :: Maybe Int } + | RunBlockBuffering { runBufferBlockSize :: Maybe Int + , runBufferTimeout :: Maybe Int + } + deriving (Typeable, Show, Generic, Eq) + +-- | The outcome of running code +data RunResult = + -- | The code terminated okay + RunOk + -- | The code threw an exception + | RunProgException String + -- | GHC itself threw an exception when we tried to run the code + | RunGhcException String + -- | The session was restarted + | RunForceCancelled + -- | Execution was paused because of a breakpoint + | RunBreak + deriving (Typeable, Show, Eq, Generic) + +-- | Information about a triggered breakpoint +data BreakInfo = BreakInfo { + -- | Module containing the breakpoint + breakInfoModule :: ModuleName + -- | Location of the breakpoint + , breakInfoSpan :: SourceSpan + -- | Type of the result + , breakInfoResultType :: Type + -- | Local variables and their values + , breakInfoVariableEnv :: VariableEnv + } + deriving (Typeable, Show, Eq, Generic) + +-- | We present values only in pretty-printed form +type Value = Text + +-- | Variables during execution (in debugging mode) +type VariableEnv = [(Name, Type, Value)] + +data Targets = TargetsInclude [FilePath] | TargetsExclude [FilePath] + deriving (Typeable, Generic, Eq, Show) + +{------------------------------------------------------------------------------ + Show instances +------------------------------------------------------------------------------} + +instance Show SourceSpan where + show (SourceSpan{..}) = + spanFilePath ++ "@" + ++ show spanFromLine ++ ":" ++ show spanFromColumn ++ "-" + ++ show spanToLine ++ ":" ++ show spanToColumn + +instance Show IdProp where + show (IdProp {..}) = + Text.unpack idName ++ " " + ++ "(" ++ show idSpace ++ ")" + ++ (case idType of Just typ -> " :: " ++ Text.unpack typ; Nothing -> []) + ++ " defined in " + ++ show idDefinedIn + ++ " at " ++ show idDefSpan + ++ (case idHomeModule of Just home -> " (home " ++ show home ++ ")" + Nothing -> "") + +instance Show IdScope where + show Binder = "binding occurrence" + show Local = "defined locally" + show WiredIn = "wired in to the compiler" + show (Imported {..}) = + "imported from " ++ show idImportedFrom + ++ (if Text.null idImportQual + then [] + else " as '" ++ Text.unpack idImportQual ++ "'") + ++ " at "++ show idImportSpan + +instance Show EitherSpan where + show (ProperSpan srcSpan) = show srcSpan + show (TextSpan str) = Text.unpack str + +instance Show ModuleId where + show (ModuleId mo pkg) = show pkg ++ ":" ++ Text.unpack mo + +instance Show PackageId where + show (PackageId name (Just version) _pkey) = + Text.unpack name ++ "-" ++ Text.unpack version + show (PackageId name Nothing _pkey) = + Text.unpack name + +instance Show IdInfo where + show IdInfo{..} = show idProp ++ " (" ++ show idScope ++ ")" + +instance Show SpanInfo where + show (SpanId idInfo) = show idInfo + show (SpanQQ idInfo) = "quasi-quote with quoter " ++ show idInfo + +{- +instance Show IdMap where + show = + let showIdInfo(span, idInfo) = "(" ++ show span ++ "," ++ show idInfo ++ ")" + in unlines . map showIdInfo . Map.toList . idMapToMap +-} + +{------------------------------------------------------------------------------ + Binary instances + + We only have Binary instances for those types that are shared between + the public and private types, and for the "small" types that are the result of + IDE session queries. We don't want Binary instances for entire LoadedModules + maps and other "large" types. +------------------------------------------------------------------------------} + +instance Binary IdNameSpace where + put VarName = putWord8 0 + put DataName = putWord8 1 + put TvName = putWord8 2 + put TcClsName = putWord8 3 + + get = do + header <- getWord8 + case header of + 0 -> return VarName + 1 -> return DataName + 2 -> return TvName + 3 -> return TcClsName + _ -> fail "IdNameSpace.get: invalid header" + +instance Binary SourceErrorKind where + put KindError = putWord8 0 + put KindWarning = putWord8 1 + put KindServerDied = putWord8 2 + + get = do + header <- getWord8 + case header of + 0 -> return KindError + 1 -> return KindWarning + 2 -> return KindServerDied + _ -> fail "SourceErrorKind.get: invalid header" + +instance Binary ImportEntities where + put (ImportOnly names) = putWord8 0 >> put names + put (ImportHiding names) = putWord8 1 >> put names + put ImportAll = putWord8 2 + + get = do + header <- getWord8 + case header of + 0 -> ImportOnly <$> get + 1 -> ImportHiding <$> get + 2 -> return ImportAll + _ -> fail "ImportEntities.get: invalid header" + +instance Binary Import where + put Import{..} = do + put importModule + put importPackage + put importQualified + put importImplicit + put importAs + put importEntities + + get = Import <$> get <*> get <*> get <*> get <*> get <*> get + +instance Binary SourceError where + put SourceError{..} = do + put errorKind + put errorSpan + put errorMsg + + get = SourceError <$> get <*> get <*> get + +instance Binary IdProp where + put IdProp{..} = do + put idName + put idSpace + put idType + put idDefinedIn + put idDefSpan + put idHomeModule + + get = IdProp <$> get <*> get <*> get <*> get <*> get <*> get + +instance Binary IdScope where + put Binder = putWord8 0 + put Local = putWord8 1 + put Imported{..} = do putWord8 2 + put idImportedFrom + put idImportSpan + put idImportQual + put WiredIn = putWord8 3 + + get = do + header <- getWord8 + case header of + 0 -> return Binder + 1 -> return Local + 2 -> Imported <$> get <*> get <*> get + 3 -> return WiredIn + _ -> fail "IdScope.get: invalid header" + +instance Binary SourceSpan where + put (SourceSpan{..}) = do + put spanFilePath + put spanFromLine + put spanFromColumn + put spanToLine + put spanToColumn + + get = SourceSpan <$> get <*> get <*> get <*> get <*> get + +instance Binary EitherSpan where + put (ProperSpan span) = putWord8 0 >> put span + put (TextSpan text) = putWord8 1 >> put text + + get = do + header <- getWord8 + case header of + 0 -> ProperSpan <$> get + 1 -> TextSpan <$> get + _ -> fail "EitherSpan.get: invalid header" + +instance Binary ModuleId where + put ModuleId{..} = put moduleName >> put modulePackage + get = ModuleId <$> get <*> get + +instance Binary PackageId where + put PackageId{..} = do + put packageName + put packageVersion + put packageKey + get = PackageId <$> get <*> get <*> get + +instance Binary IdInfo where + put IdInfo{..} = put idProp >> put idScope + get = IdInfo <$> get <*> get + +instance Binary RunBufferMode where + put RunNoBuffering = putWord8 0 + put RunLineBuffering{..} = do putWord8 1 + put runBufferTimeout + put RunBlockBuffering{..} = do putWord8 2 + put runBufferBlockSize + put runBufferTimeout + + get = do + header <- getWord8 + case header of + 0 -> return RunNoBuffering + 1 -> RunLineBuffering <$> get + 2 -> RunBlockBuffering <$> get <*> get + _ -> fail "RunBufferMode.get: invalid header" + +instance Binary Targets where + put (TargetsInclude l) = do + putWord8 0 + put l + put (TargetsExclude l) = do + putWord8 1 + put l + + get = do + header <- getWord8 + case header of + 0 -> TargetsInclude <$> get + 1 -> TargetsExclude <$> get + _ -> fail "Targets.get: invalid header" + +{------------------------------------------------------------------------------ + JSON instances + + We provide these for the convenience of client code only; we don't use them + internally. +------------------------------------------------------------------------------} + +$(deriveJSON defaultOptions ''IdNameSpace) +$(deriveJSON defaultOptions ''SourceErrorKind) +$(deriveJSON defaultOptions ''ImportEntities) +$(deriveJSON defaultOptions ''Import) +$(deriveJSON defaultOptions ''SourceError) +$(deriveJSON defaultOptions ''IdProp) +$(deriveJSON defaultOptions ''IdScope) +$(deriveJSON defaultOptions ''SourceSpan) +$(deriveJSON defaultOptions ''EitherSpan) +$(deriveJSON defaultOptions ''ModuleId) +$(deriveJSON defaultOptions ''PackageId) +$(deriveJSON defaultOptions ''IdInfo) +$(deriveJSON defaultOptions ''SpanInfo) +$(deriveJSON defaultOptions ''BreakInfo) +$(deriveJSON defaultOptions ''RunResult) +$(deriveJSON defaultOptions ''RunBufferMode) + +{------------------------------------------------------------------------------ + PrettyVal instances (these rely on Generics) +------------------------------------------------------------------------------} + +instance PrettyVal IdNameSpace +instance PrettyVal IdInfo +instance PrettyVal IdProp +instance PrettyVal IdScope +instance PrettyVal SourceSpan +instance PrettyVal EitherSpan +instance PrettyVal SourceError +instance PrettyVal SourceErrorKind +instance PrettyVal ModuleId +instance PrettyVal PackageId +instance PrettyVal ImportEntities +instance PrettyVal Import +instance PrettyVal SpanInfo +instance PrettyVal RunBufferMode +instance PrettyVal RunResult +instance PrettyVal BreakInfo +instance PrettyVal Targets + +{------------------------------------------------------------------------------ + Util +------------------------------------------------------------------------------} + +-- | Construct qualified name following Haskell's scoping rules +idInfoQN :: IdInfo -> String +idInfoQN IdInfo{idProp = IdProp{idName}, idScope} = + case idScope of + Binder -> Text.unpack idName + Local{} -> Text.unpack idName + Imported{idImportQual} -> Text.unpack idImportQual ++ Text.unpack idName + WiredIn -> Text.unpack idName + +-- | Show approximately what Haddock adds to documentation URLs. +haddockSpaceMarks :: IdNameSpace -> String +haddockSpaceMarks VarName = "v" +haddockSpaceMarks DataName = "v" +haddockSpaceMarks TvName = "t" +haddockSpaceMarks TcClsName = "t" + +-- | Show approximately a haddock link (without haddock root) for an id. +-- This is an illustration and a test of the id info, but under ideal +-- conditions could perhaps serve to link to documentation without +-- going via Hoogle. +haddockLink :: IdProp -> IdScope -> String +haddockLink IdProp{..} idScope = + case idScope of + Imported{idImportedFrom} -> + dashToSlash (modulePackage idImportedFrom) + ++ "/doc/html/" + ++ dotToDash (Text.unpack $ moduleName idImportedFrom) ++ ".html#" + ++ haddockSpaceMarks idSpace ++ ":" + ++ Text.unpack idName + _ -> "" + where + dotToDash = map (\c -> if c == '.' then '-' else c) + dashToSlash p = case packageVersion p of + Nothing -> Text.unpack (packageName p) ++ "/latest" + Just version -> Text.unpack (packageName p) ++ "/" ++ Text.unpack version + +{- +idInfoAtLocation :: Int -> Int -> IdMap -> [(SourceSpan, IdInfo)] +idInfoAtLocation line col = filter inRange . idMapToList + where + inRange :: (SourceSpan, a) -> Bool + inRange (SourceSpan{..}, _) = + (line > spanFromLine || (line == spanFromLine && col >= spanFromColumn)) && + (line < spanToLine || (line == spanToLine && col <= spanToColumn)) +-} diff --git a/IdeSession/Types/Translation.hs b/IdeSession/Types/Translation.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Types/Translation.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE TypeFamilies, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} +-- | Translation from the private to the public types +module IdeSession.Types.Translation ( + XShared + , ExplicitSharing(..) + , IntroduceSharing(..) + , showNormalized + , dereferenceFilePathPtr + ) where + +import Prelude hiding (mod, span) +import qualified Data.ByteString.Char8 as BSSC +import qualified Data.Text as Text +import Data.Binary (Binary) + +import IdeSession.Strict.Container +import qualified IdeSession.Types.Public as Public +import qualified IdeSession.Types.Private as Private +import qualified IdeSession.Strict.IntMap as StrictIntMap +import qualified IdeSession.Strict.Maybe as StrictMaybe + +-- | The associated type with explicit sharing +type family XShared a + +-- | The inverse of MShared, only for decidability of type checking +type family MShared a + +type instance XShared Public.IdProp = Private.IdProp +type instance XShared Public.IdInfo = Private.IdInfo +type instance XShared Public.IdScope = Private.IdScope +type instance XShared Public.SourceSpan = Private.SourceSpan +type instance XShared Public.EitherSpan = Private.EitherSpan +type instance XShared Public.SourceError = Private.SourceError +-- type instance XShared Public.IdMap = Private.IdMap +-- type instance XShared Public.LoadedModules = Private.LoadedModules +type instance XShared Public.ModuleId = Private.ModuleId +type instance XShared Public.PackageId = Private.PackageId +type instance XShared Public.ImportEntities = Private.ImportEntities +type instance XShared Public.Import = Private.Import +type instance XShared Public.SpanInfo = Private.SpanInfo +type instance XShared Public.RunResult = Private.RunResult +type instance XShared Public.BreakInfo = Private.BreakInfo + +type instance MShared Private.IdProp = Public.IdProp +type instance MShared Private.IdInfo = Public.IdInfo +type instance MShared Private.IdScope = Public.IdScope +type instance MShared Private.SourceSpan = Public.SourceSpan +type instance MShared Private.EitherSpan = Public.EitherSpan +type instance MShared Private.SourceError = Public.SourceError +-- type instance MShared Private.IdMap = Public.IdMap +-- type instance MShared Private.LoadedModules = Public.LoadedModules +type instance MShared Private.ModuleId = Public.ModuleId +type instance MShared Private.PackageId = Public.PackageId +type instance MShared Private.ImportEntities = Public.ImportEntities +type instance MShared Private.Import = Public.Import +type instance MShared Private.SpanInfo = Public.SpanInfo +type instance MShared Private.RunResult = Public.RunResult +type instance MShared Private.BreakInfo = Public.BreakInfo + +{------------------------------------------------------------------------------ + Removing explicit sharing +------------------------------------------------------------------------------} + +-- | Many of the public data types that we export in "IdeSession" have a +-- corresponding private @XShared@ version. For instance, we have @IdProp@ and +-- @XShared IdProp@, @SourceError@ and @XShared SourceError@, etc. These +-- @XShared@ types are abstract; what's important is only that they can be +-- serialized (support @FromJSON@ and @ToJSON@). The main difference between +-- the public and the private data types is that the private data types use +-- explicit sharing. This is important for serialization, because there is +-- quite a bit of sharing in the type information that we collect and losing +-- this would be a significant performance hit. (The other difference is that +-- the private data types use specialized types that guarantee strictness.) +-- +-- The @MShared (XShared a) ~ a@ condition on the @ExplicitSharing@ type class +-- is there for technical reasons only (it convinces GHC that the @XShared@ +-- type family is a bijection). +class (MShared (XShared a) ~ a, Binary (XShared a)) => ExplicitSharing a where + removeExplicitSharing :: Private.ExplicitSharingCache -> XShared a -> a + +showNormalized :: forall a. (Show a, ExplicitSharing a) + => Private.ExplicitSharingCache -> XShared a -> String +showNormalized cache x = show (removeExplicitSharing cache x :: a) + +instance ExplicitSharing Public.IdProp where + removeExplicitSharing cache Private.IdProp{..} = Public.IdProp { + Public.idName = idName + , Public.idSpace = idSpace + , Public.idType = toLazyMaybe idType + , Public.idDefSpan = removeExplicitSharing cache idDefSpan + , Public.idDefinedIn = removeExplicitSharing cache idDefinedIn + , Public.idHomeModule = StrictMaybe.maybe + Nothing + (Just . removeExplicitSharing cache) + idHomeModule + } + +instance ExplicitSharing Public.IdInfo where + removeExplicitSharing cache Private.IdInfo{..} = Public.IdInfo { + Public.idProp = case StrictIntMap.lookup (Private.idPropPtr idProp) + (Private.idPropCache cache) + of Just idProp' -> removeExplicitSharing cache idProp' + Nothing -> unknownProp + , Public.idScope = removeExplicitSharing cache idScope + } + where + unknownProp = Public.IdProp { + idName = Text.pack "<>" + , idSpace = Public.VarName + , idType = Nothing + , idDefinedIn = unknownModule + , idDefSpan = Public.TextSpan (Text.pack "<>") + , idHomeModule = Nothing + } + + unknownModule = Public.ModuleId { + moduleName = Text.pack "<>" + , modulePackage = unknownPackage + } + + unknownPackage = Public.PackageId { + packageName = Text.pack "<>" + , packageVersion = Nothing + , packageKey = Text.pack "<>" + } + +instance ExplicitSharing Public.ModuleId where + removeExplicitSharing cache Private.ModuleId{..} = Public.ModuleId { + Public.moduleName = moduleName + , Public.modulePackage = removeExplicitSharing cache modulePackage + } + +instance ExplicitSharing Public.PackageId where + removeExplicitSharing _cache Private.PackageId{..} = Public.PackageId { + Public.packageName = packageName + , Public.packageVersion = toLazyMaybe packageVersion + , Public.packageKey = packageKey + } + +instance ExplicitSharing Public.IdScope where + removeExplicitSharing cache idScope = case idScope of + Private.Binder -> Public.Binder + Private.Local -> Public.Local + Private.Imported {..} -> Public.Imported { + Public.idImportedFrom = removeExplicitSharing cache idImportedFrom + , Public.idImportSpan = removeExplicitSharing cache idImportSpan + , Public.idImportQual = idImportQual + } + Private.WiredIn -> Public.WiredIn + +instance ExplicitSharing Public.SourceSpan where + removeExplicitSharing cache Private.SourceSpan{..} = Public.SourceSpan { + Public.spanFilePath = dereferenceFilePathPtr cache spanFilePath + , Public.spanFromLine = spanFromLine + , Public.spanFromColumn = spanFromColumn + , Public.spanToLine = spanToLine + , Public.spanToColumn = spanToColumn + } + +instance ExplicitSharing Public.EitherSpan where + removeExplicitSharing cache eitherSpan = case eitherSpan of + Private.ProperSpan sourceSpan -> + Public.ProperSpan (removeExplicitSharing cache sourceSpan) + Private.TextSpan str -> + Public.TextSpan str + +instance ExplicitSharing Public.SourceError where + removeExplicitSharing cache Private.SourceError{..} = Public.SourceError { + Public.errorKind = errorKind + , Public.errorSpan = removeExplicitSharing cache errorSpan + , Public.errorMsg = errorMsg + } + +{- +instance ExplicitSharing Public.IdMap where + removeExplicitSharing cache = Public.IdMap + . toLazyMap + . StrictMap.map (removeExplicitSharing cache) + . StrictMap.mapKeys (removeExplicitSharing cache) + . Private.idMapToMap +-} + +{- +instance ExplicitSharing Public.LoadedModules where + removeExplicitSharing cache = Map.map (removeExplicitSharing cache) + . toLazyMap +-} + +instance ExplicitSharing Public.ImportEntities where + removeExplicitSharing _cache entities = case entities of + Private.ImportAll -> Public.ImportAll + Private.ImportHiding names -> Public.ImportHiding (toLazyList names) + Private.ImportOnly names -> Public.ImportOnly (toLazyList names) + +instance ExplicitSharing Public.Import where + removeExplicitSharing cache Private.Import{..} = Public.Import { + Public.importModule = removeExplicitSharing cache $ importModule + , Public.importPackage = toLazyMaybe importPackage + , Public.importQualified = importQualified + , Public.importImplicit = importImplicit + , Public.importAs = toLazyMaybe importAs + , Public.importEntities = removeExplicitSharing cache $ importEntities + } + +instance ExplicitSharing Public.SpanInfo where + removeExplicitSharing cache spanInfo = case spanInfo of + Private.SpanId idInfo -> Public.SpanId (removeExplicitSharing cache idInfo) + Private.SpanQQ idInfo -> Public.SpanQQ (removeExplicitSharing cache idInfo) + Private.SpanInSplice idInfo -> Public.SpanId (removeExplicitSharing cache idInfo) + +instance ExplicitSharing Public.BreakInfo where + removeExplicitSharing cache Private.BreakInfo{..} = Public.BreakInfo { + Public.breakInfoModule = breakInfoModule + , Public.breakInfoSpan = removeExplicitSharing cache breakInfoSpan + , Public.breakInfoResultType = breakInfoResultType + , Public.breakInfoVariableEnv = breakInfoVariableEnv + } + +{------------------------------------------------------------------------------ + Low-level API +------------------------------------------------------------------------------} + +dereferenceFilePathPtr :: Private.ExplicitSharingCache + -> Private.FilePathPtr -> FilePath +dereferenceFilePathPtr cache ptr = BSSC.unpack $ + StrictIntMap.findWithDefault + unknownFilePath + (Private.filePathPtr ptr) + (Private.filePathCache cache) + where + unknownFilePath = BSSC.pack "<>" + +{------------------------------------------------------------------------------ + Introducing explicit sharing +------------------------------------------------------------------------------} + +-- | Introduce explicit sharing +-- +-- This provides the opposite translation to removeExplicitSharing. Note however +-- that this is a partial function -- we never extend the cache, so if a +-- required value is missing from the cache we return @Nothing@. +class IntroduceSharing a where + introduceExplicitSharing :: Private.ExplicitSharingCache -> a -> Maybe (XShared a) + +instance IntroduceSharing Public.SourceSpan where + introduceExplicitSharing cache Public.SourceSpan{..} = do + ptr <- StrictIntMap.reverseLookup (Private.filePathCache cache) + (BSSC.pack spanFilePath) + return Private.SourceSpan { + Private.spanFilePath = Private.FilePathPtr ptr + , Private.spanFromLine = spanFromLine + , Private.spanFromColumn = spanFromColumn + , Private.spanToLine = spanToLine + , Private.spanToColumn = spanToColumn + } diff --git a/IdeSession/Update.hs b/IdeSession/Update.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Update.hs @@ -0,0 +1,709 @@ +{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, ScopedTypeVariables, TemplateHaskell #-} +-- | IDE session updates +-- +-- We should only be using internal types here (explicit strictness/sharing) +module IdeSession.Update ( + -- * Starting and stopping + initSession + , SessionInitParams(..) + , defaultSessionInitParams + , shutdownSession + , forceShutdownSession + , restartSession + -- * Session updates + , IdeSessionUpdate -- Abstract + , updateSession + , updateSourceFile + , updateSourceFileFromFile + , updateSourceFileDelete + , updateGhcOpts + , updateRtsOpts + , updateRelativeIncludes + , updateCodeGeneration + , updateDataFile + , updateDataFileFromFile + , updateDataFileDelete + , updateDeleteManagedFiles + , updateEnv + , updateArgs + , updateStdoutBufferMode + , updateStderrBufferMode + , updateTargets + , buildExe + , buildDoc + , buildLicenses + -- * Running code + , runStmt + , runExe + , resume + , setBreakpoint + , printVar + -- * Debugging + , crashGhcServer + , buildLicsFromPkgs + , LicenseArgs(..) + ) + where + +import Prelude hiding (mod, span) +import Control.Concurrent (threadDelay) +import Control.Monad (when, unless) +import Control.Monad.IO.Class (liftIO) +import Data.Accessor (Accessor, (^.)) +import Data.List (elemIndices, isPrefixOf) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid(..), (<>)) +import Distribution.Simple (PackageDBStack, PackageDB(..)) +import System.Environment (getEnv, getEnvironment) +import System.Exit (ExitCode(..)) +import System.FilePath (()) +import System.IO.Temp (createTempDirectory) +import System.Posix.IO.ByteString +import System.Process (proc, CreateProcess(..), StdStream(..), createProcess, waitForProcess, interruptProcessGroupOf, terminateProcess) +import qualified Control.Exception as Ex +import qualified Data.ByteString as BSS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.UTF8 as BSL.UTF8 +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified System.Directory as Dir +import qualified System.IO as IO + +import IdeSession.Cabal +import IdeSession.Config +import IdeSession.GHC.API +import IdeSession.GHC.Client +import IdeSession.RPC.API (ExternalException(..)) +import IdeSession.State +import IdeSession.Strict.Container +import IdeSession.Strict.MVar (newMVar, newEmptyMVar, StrictMVar) +import IdeSession.Types.Private hiding (RunResult(..)) +import IdeSession.Types.Progress +import IdeSession.Types.Public (RunBufferMode(..)) +import IdeSession.Update.ExecuteSessionUpdate +import IdeSession.Update.IdeSessionUpdate +import IdeSession.Util +import IdeSession.Util.BlockingOps +import qualified IdeSession.Query as Query +import qualified IdeSession.Strict.List as List +import qualified IdeSession.Strict.Map as Map +import qualified IdeSession.Strict.Maybe as Maybe +import qualified IdeSession.Types.Private as Private +import qualified IdeSession.Types.Public as Public + +{------------------------------------------------------------------------------- + Session initialization +-------------------------------------------------------------------------------} + +-- | How should the session be initialized? +-- +-- Client code should use 'defaultSessionInitParams' to protect itself against +-- future extensions of this record. +data SessionInitParams = SessionInitParams { + -- | Previously computed cabal macros, + -- or 'Nothing' to compute them on startup + sessionInitCabalMacros :: Maybe BSL.ByteString + + -- | Initial ghc options + , sessionInitGhcOptions :: [String] + + -- | Include paths (equivalent of GHC's @-i@ parameter) relative to the + -- temporary directory where we store the session's source files. + -- + -- By default this is the singleton list @[""]@ -- i.e., we include the + -- sources dir but nothing else. + , sessionInitRelativeIncludes :: [FilePath] + + -- | Targets for compilation + -- + -- Defaults to @TargetsExclude []@ -- i.e., compile all modules in the + -- project. + , sessionInitTargets :: Public.Targets + + -- | RTS options + -- + -- Defaults to @-K8M@ + , sessionInitRtsOpts :: [String] + } + deriving Show + +defaultSessionInitParams :: SessionInitParams +defaultSessionInitParams = SessionInitParams { + sessionInitCabalMacros = Nothing + , sessionInitGhcOptions = [] + , sessionInitRelativeIncludes = [""] + , sessionInitTargets = Public.TargetsExclude [] + , sessionInitRtsOpts = ["-K8M"] + } + +-- | Session initialization parameters for an existing session. +-- +-- For internal use only (used in 'updateSession' when restarting the session). +-- +-- We set 'sessionInitCabalMacros' to 'Nothing' because the cabal macros file +-- has already been written to disk, and we don't remove the project directory +-- on a session restart. +sessionRestartParams :: IdeIdleState -> IdeSessionUpdate -> SessionInitParams +sessionRestartParams st IdeSessionUpdate{..} = SessionInitParams { + sessionInitCabalMacros = Nothing + , sessionInitGhcOptions = fromMaybe (st ^. ideGhcOpts) ideUpdateGhcOpts + , sessionInitRelativeIncludes = fromMaybe (st ^. ideRelativeIncludes) ideUpdateRelIncls + , sessionInitTargets = fromMaybe (st ^. ideTargets) ideUpdateTargets + , sessionInitRtsOpts = fromMaybe (st ^. ideRtsOpts) ideUpdateRtsOpts + } + +-- | Set up the initial state of the session according to the given parameters +execInitParams :: IdeStaticInfo -> SessionInitParams -> IO () +execInitParams staticInfo SessionInitParams{..} = do + writeMacros staticInfo sessionInitCabalMacros + +-- | Write per-package CPP macros. +writeMacros :: IdeStaticInfo -> Maybe BSL.ByteString -> IO () +writeMacros IdeStaticInfo{ideConfig = SessionConfig {..}, ..} + configCabalMacros = do + macros <- case configCabalMacros of + Nothing -> generateMacros configPackageDBStack configExtraPathDirs + Just macros -> return (BSL.UTF8.toString macros) + writeFile (cabalMacrosLocation (ideSessionDistDir ideSessionDir)) macros + +{------------------------------------------------------------------------------- + Session startup +-------------------------------------------------------------------------------} + +-- | Create a fresh session, using some initial configuration. +-- +-- Throws an exception if the configuration is invalid, or if GHC_PACKAGE_PATH +-- is set. +initSession :: SessionInitParams -> SessionConfig -> IO IdeSession +initSession initParams@SessionInitParams{..} ideConfig@SessionConfig{..} = do + verifyConfig ideConfig + + configDirCanon <- Dir.canonicalizePath configDir + ideSessionDir <- createTempDirectory configDirCanon "session." + let ideStaticInfo = IdeStaticInfo{..} + + -- Create the common subdirectories of session.nnnn so that we don't have to + -- worry about creating these elsewhere + Dir.createDirectoryIfMissing True (ideSessionSourceDir ideSessionDir) + Dir.createDirectoryIfMissing True (ideSessionDataDir ideSessionDir) + Dir.createDirectoryIfMissing True (ideSessionDistDir ideSessionDir) + Dir.createDirectoryIfMissing True (ideSessionObjDir ideSessionDir) + + -- Local initialization + execInitParams ideStaticInfo initParams + + -- Start the GHC server (as a separate process) + mServer <- forkGhcServer sessionInitGhcOptions + sessionInitRelativeIncludes + sessionInitRtsOpts + ideStaticInfo + let (state, server, version) = case mServer of + Right (s, v) -> (IdeSessionIdle, s, v) + Left e -> (IdeSessionServerDied e, Ex.throw e, Ex.throw e) + + -- The value of _ideLogicalTimestamp field is a workaround for + -- the problems with 'invalidateModSummaryCache', which itself is + -- a workaround for http://hackage.haskell.org/trac/ghc/ticket/7478. + -- We have to make sure that file times never reach 0, because this will + -- trigger an exception (http://hackage.haskell.org/trac/ghc/ticket/7567). + -- We rather arbitrary start at Jan 2, 1970. + let idleState = IdeIdleState { + _ideLogicalTimestamp = 86400 + , _ideComputed = Maybe.nothing + , _ideGenerateCode = False + , _ideManagedFiles = ManagedFilesInternal [] [] + , _ideObjectFiles = [] + , _ideBuildExeStatus = Nothing + , _ideBuildDocStatus = Nothing + , _ideBuildLicensesStatus = Nothing + , _ideEnv = [] + , _ideArgs = [] + , _ideStdoutBufferMode = RunNoBuffering + , _ideStderrBufferMode = RunNoBuffering + , _ideBreakInfo = Maybe.nothing + , _ideGhcServer = server + , _ideGhcVersion = version + , _ideGhcOpts = sessionInitGhcOptions + , _ideRelativeIncludes = sessionInitRelativeIncludes + , _ideTargets = sessionInitTargets + , _ideRtsOpts = sessionInitRtsOpts + } + + ideState <- newMVar (state idleState) + return IdeSession{..} + +-- | Verify configuration, and throw an exception if configuration is invalid +verifyConfig :: SessionConfig -> IO () +verifyConfig SessionConfig{..} = do + unless (isValidPackageDB configPackageDBStack) $ + Ex.throw . userError $ "Invalid package DB stack: " + ++ show configPackageDBStack + + checkPackageDbEnvVar + where + isValidPackageDB :: PackageDBStack -> Bool + isValidPackageDB stack = + elemIndices GlobalPackageDB stack == [0] + && elemIndices UserPackageDB stack `elem` [[], [1]] + +-- Copied directly from Cabal +checkPackageDbEnvVar :: IO () +checkPackageDbEnvVar = do + hasGPP <- (getEnv "GHC_PACKAGE_PATH" >> return True) + `catchIO` (\_ -> return False) + when hasGPP $ + die $ "Use of GHC's environment variable GHC_PACKAGE_PATH is " + ++ "incompatible with Cabal. Use the flag --package-db to specify a " + ++ "package database (it can be used multiple times)." + where + -- Definitions so that the copied code from Cabal works + + die = Ex.throwIO . userError + + catchIO :: IO a -> (IOError -> IO a) -> IO a + catchIO = Ex.catch + +{------------------------------------------------------------------------------- + Session shutdown +-------------------------------------------------------------------------------} + +-- | Close a session down, releasing the resources. +-- +-- This operation is the only one that can be run after a shutdown was already +-- performed. This lets the API user execute an early shutdown, e.g., before +-- the @shutdownSession@ placed inside 'bracket' is triggered by a normal +-- program control flow. +-- +-- If code is still running, it will be interrupted. +shutdownSession :: IdeSession -> IO () +shutdownSession = shutdownSession' False + +-- | Like shutdownSession, but don't be nice about it (SIGKILL) +forceShutdownSession :: IdeSession -> IO () +forceShutdownSession = shutdownSession' True + +-- | Internal generalization of 'shutdownSession' and 'forceShutdownSession' +shutdownSession' :: Bool -> IdeSession -> IO () +shutdownSession' forceTerminate IdeSession{ideState, ideStaticInfo} = do + $modifyStrictMVar_ ideState $ \state -> + case state of + IdeSessionIdle idleState -> do + if forceTerminate + then forceShutdownGhcServer $ _ideGhcServer idleState + else shutdownGhcServer $ _ideGhcServer idleState + cleanupDirs + return IdeSessionShutdown + IdeSessionShutdown -> + return IdeSessionShutdown + IdeSessionServerDied _ _ -> do + cleanupDirs + return IdeSessionShutdown + where + cleanupDirs :: IO () + cleanupDirs = + when (configDeleteTempFiles . ideConfig $ ideStaticInfo) $ + ignoreDoesNotExist $ + Dir.removeDirectoryRecursive (ideSessionDir ideStaticInfo) + +{------------------------------------------------------------------------------- + Session restart +-------------------------------------------------------------------------------} + +-- | Restart a session +-- +-- This puts the session in a "dead" state; it won't _actually_ be restarted +-- until the next call to 'updateSession'. +restartSession :: IdeSession -> IO () +restartSession IdeSession{ideState} = + $modifyStrictMVar_ ideState $ \state -> + case state of + IdeSessionIdle idleState -> + return $ IdeSessionServerDied forcedRestart idleState + IdeSessionServerDied _ _ -> + return state -- Leave Died state as is + IdeSessionShutdown -> + fail "Shutdown session cannot be restarted." + +data RestartResult = + ServerRestarted IdeIdleState IdeSessionUpdate + | ServerRestartFailed IdeIdleState + +executeRestart :: SessionInitParams + -> IdeStaticInfo + -> IdeIdleState + -> IO RestartResult +executeRestart initParams@SessionInitParams{..} staticInfo idleState = do + forceShutdownGhcServer $ _ideGhcServer idleState + mServer <- forkGhcServer sessionInitGhcOptions + sessionInitRelativeIncludes + sessionInitRtsOpts + staticInfo + case mServer of + Right (server, version) -> do + execInitParams staticInfo initParams + + -- Reset back to initial values .. + let idleState' = idleState { + _ideComputed = Maybe.nothing + , _ideGhcOpts = sessionInitGhcOptions + , _ideRelativeIncludes = sessionInitRelativeIncludes + , _ideRtsOpts = sessionInitRtsOpts + , _ideGenerateCode = False + , _ideObjectFiles = [] + , _ideEnv = [] + , _ideArgs = [] + , _ideGhcServer = server + , _ideGhcVersion = version + , _ideTargets = sessionInitTargets + } + -- .. and let an update make sure we bring the state back to where it was + let upd = mconcat [ + updateEnv (idleState ^. ideEnv) + , updateArgs (idleState ^. ideArgs) + , updateCodeGeneration (idleState ^. ideGenerateCode) + ] + return (ServerRestarted idleState' upd) + Left e -> do + let idleState' = idleState { + _ideGhcServer = Ex.throw e + , _ideGhcVersion = Ex.throw e + } + return (ServerRestartFailed idleState') + +{------------------------------------------------------------------------------- + Session update + + Here we deal only with the top-level logic: restart the session and then run + the session update. The specifics of how to execute the individual parts + of the session update are defined in IdeSession.Update.ExecuteSessionUpdate. +-------------------------------------------------------------------------------} + +-- | Given the current IDE session state, go ahead and update the session, +-- eventually resulting in a new session state, with fully updated computed +-- information (typing, etc.). +-- +-- The update can be a long running operation, so we support a callback which +-- can be used to monitor progress of the operation. +updateSession :: IdeSession -> IdeSessionUpdate -> (Progress -> IO ()) -> IO () +updateSession = flip . updateSession' + +updateSession' :: IdeSession -> (Progress -> IO ()) -> IdeSessionUpdate -> IO () +updateSession' IdeSession{ideStaticInfo, ideState} callback = \update -> + $modifyStrictMVar_ ideState $ go False update + where + go :: Bool -> IdeSessionUpdate -> IdeSessionState -> IO IdeSessionState + go justRestarted update (IdeSessionIdle idleState) = + if not (requiresSessionRestart idleState update) + then do + (idleState', mex) <- runSessionUpdate justRestarted update ideStaticInfo callback idleState + case mex of + Nothing -> return $ IdeSessionIdle idleState' + Just ex -> return $ IdeSessionServerDied ex idleState' + else do + let restartParams = sessionRestartParams idleState update + restart justRestarted update restartParams idleState + go justRestarted update (IdeSessionServerDied _ex idleState) = do + let restartParams = sessionRestartParams idleState update + restart justRestarted update restartParams idleState + go _ _ IdeSessionShutdown = + Ex.throwIO (userError "Session already shut down.") + + restart :: Bool -> IdeSessionUpdate -> SessionInitParams -> IdeIdleState -> IO IdeSessionState + restart True _ _ idleState = + return $ IdeSessionServerDied serverRestartLoop idleState + restart False update restartParams idleState = do + -- To avoid " hPutChar: resource vanished (Broken pipe)": + -- TODO: I wish I knew why this is necessary :( + threadDelay 100000 + + restartResult <- executeRestart restartParams ideStaticInfo idleState + case restartResult of + ServerRestarted idleState' resetSession -> + go True (resetSession <> update) (IdeSessionIdle idleState') + ServerRestartFailed idleState' -> + return $ IdeSessionServerDied failedToRestart idleState' + +-- | @requiresSessionRestart st upd@ returns true if update @upd@ requires a +-- session restart given current state @st@. +-- +-- See 'sessionRestartParams' to compute the session initialization parameters +-- for the new session. +requiresSessionRestart :: IdeIdleState -> IdeSessionUpdate -> Bool +requiresSessionRestart st IdeSessionUpdate{..} = + (ideUpdateRelIncls `changes` ideRelativeIncludes) + || (ideUpdateTargets `changes` ideTargets) + || (ideUpdateRtsOpts `changes` ideRtsOpts) + || (any optRequiresRestart (listChanges' ideUpdateGhcOpts ideGhcOpts)) + where + optRequiresRestart :: String -> Bool + optRequiresRestart str = + -- Library flags cannot be changed dynamically (#214) + "-l" `isPrefixOf` str + + changes :: Eq a => Maybe a -> Accessor IdeIdleState a -> Bool + changes Nothing _ = False + changes (Just x) y = x /= st ^. y + + listChanges' :: Ord a => Maybe [a] -> Accessor IdeIdleState [a] -> [a] + listChanges' Nothing _ = [] + listChanges' (Just xs) ys = listChanges xs (st ^. ys) + +-- | @listChanges xs ys@ is the list of elements that appear in @xs@ but not +-- in @ys@ and the set of elements that appear in @ys@ but not in @xs@. +-- +-- Considering the lists as sets, it is the complement of the intersection +-- between the two sets. +listChanges :: Ord a => [a] -> [a] -> [a] +listChanges xs ys = + Set.toList $ (a `Set.union` b) `Set.difference` (a `Set.intersection` b) + where + a = Set.fromList xs + b = Set.fromList ys + +{------------------------------------------------------------------------------- + Running code +-------------------------------------------------------------------------------} + +-- | Run a given function in a given module (the name of the module +-- is the one between @module ... end@, which may differ from the file name). +-- The function resembles a query, but it's not instantaneous +-- and the running code can be interrupted or interacted with. +-- +-- 'runStmt' will throw an exception if the code has not been compiled yet, +-- or when the server is in a dead state (i.e., when ghc has crashed). In the +-- latter case 'getSourceErrors' will report the ghc exception; it is the +-- responsibility of the client code to check for this. +runStmt :: IdeSession -> String -> String -> IO (RunActions Public.RunResult) +runStmt ideSession m fun = runCmd ideSession $ \idleState -> RunStmt { + runCmdModule = m + , runCmdFunction = fun + , runCmdStdout = idleState ^. ideStdoutBufferMode + , runCmdStderr = idleState ^. ideStderrBufferMode + } + +-- | Run the main function from the last compiled executable. +-- +-- 'runExe' will throw an exception if there were no executables +-- compiled since session init, or if the last compilation was not +-- successful (checked as in @getBuildExeStatus@) +-- or if none of the executables last compiled have the supplied name +-- or when the server is in a dead state (i.e., when ghc has crashed). In the +-- last case 'getSourceErrors' will report the ghc exception; it is the +-- responsibility of the client code to check for this. +runExe :: IdeSession -> String -> IO (RunActions ExitCode) +runExe session m = do + let handleQueriesExc (_ :: Query.InvalidSessionStateQueries) = + fail $ "Wrong session state when trying to run an executable." + Ex.handle handleQueriesExc $ do + mstatus <- Query.getBuildExeStatus session + case mstatus of + Nothing -> + fail $ "No executable compilation initiated since session init." + (Just status@ExitFailure{}) -> + fail $ "Last executable compilation failed with status " + ++ show status ++ "." + Just ExitSuccess -> do + distDir <- Query.getDistDir session + dataDir <- Query.getDataDir session + args <- Query.getArgs session + envInherited <- getEnvironment + envOverride <- Query.getEnv session + let overrideVar :: (String, Maybe String) -> Strict (Map String) String + -> Strict (Map String) String + overrideVar (var, Just val) env = Map.insert var val env + overrideVar (var, Nothing) env = Map.delete var env + envMap = foldr overrideVar (Map.fromList envInherited) envOverride + let exePath = distDir "build" m m + exeExists <- Dir.doesFileExist exePath + unless exeExists $ + fail $ "No compiled executable file " + ++ m ++ " exists at path " + ++ exePath ++ "." + (stdRd, stdWr) <- liftIO createPipe + std_rd_hdl <- fdToHandle stdRd + std_wr_hdl <- fdToHandle stdWr + let cproc = (proc exePath args) { cwd = Just dataDir + , env = Just $ Map.toList envMap + , create_group = True + -- for interruptProcessGroupOf + , std_in = CreatePipe + , std_out = UseHandle std_wr_hdl + , std_err = UseHandle std_wr_hdl + } + (Just stdin_hdl, Nothing, Nothing, ph) <- createProcess cproc + + -- The runActionState holds 'Just' the result of the snippet, or 'Nothing' if + -- it has not yet terminated. + runActionsState <- newMVar Nothing + + return $ RunActions + { runWait = $modifyStrictMVar runActionsState $ \st -> case st of + Just outcome -> + return (Just outcome, Right outcome) + Nothing -> do + bs <- BSS.hGetSome std_rd_hdl blockSize + if BSS.null bs + then do + res <- waitForProcess ph + return (Just res, Right res) + else + return (Nothing, Left bs) + , interrupt = interruptProcessGroupOf ph + , supplyStdin = \bs -> BSS.hPut stdin_hdl bs >> IO.hFlush stdin_hdl + , forceCancel = terminateProcess ph + } + -- We don't need to close any handles. At the latest GC closes them. + where + -- TODO: What is a good value here? + blockSize :: Int + blockSize = 4096 + +-- | Resume a previously interrupted statement +resume :: IdeSession -> IO (RunActions Public.RunResult) +resume ideSession = runCmd ideSession (const Resume) + +-- | Internal geneneralization used in 'runStmt' and 'resume' +runCmd :: IdeSession -> (IdeIdleState -> RunCmd) -> IO (RunActions Public.RunResult) +runCmd session mkCmd = modifyIdleState session $ \idleState -> + case (toLazyMaybe (idleState ^. ideComputed), idleState ^. ideGenerateCode) of + (Just comp, True) -> do + let cmd = mkCmd idleState + + checkStateOk comp cmd + isBreak <- newEmptyMVar + runActions <- rpcRun (idleState ^. ideGhcServer) + cmd + (translateRunResult isBreak) + + -- TODO: We should register the runActions somewhere so we can do a + -- clean session shutdown? + return (IdeSessionIdle idleState, runActions) + _ -> + -- This 'fail' invocation is, in part, a workaround for + -- http://hackage.haskell.org/trac/ghc/ticket/7539 + -- which would otherwise lead to a hard GHC crash, + -- instead of providing a sensible error message + -- that we could show to the user. + fail "Cannot run before the code is generated." + where + checkStateOk :: Computed -> RunCmd -> IO () + checkStateOk comp RunStmt{..} = + -- ideManagedFiles is irrelevant, because only the module name inside + -- 'module .. where' counts. + unless (Text.pack runCmdModule `List.elem` computedLoadedModules comp) $ + fail $ "Module " ++ show runCmdModule + ++ " not successfully loaded, when trying to run code." + checkStateOk _comp Resume = + -- TODO: should we check that there is anything to resume here? + return () + + translateRunResult :: StrictMVar (Strict Maybe BreakInfo) + -> Maybe Private.RunResult + -> IO Public.RunResult + translateRunResult isBreak (Just Private.RunOk) = do + $putStrictMVar isBreak Maybe.nothing + return $ Public.RunOk + translateRunResult isBreak (Just (Private.RunProgException str)) = do + $putStrictMVar isBreak Maybe.nothing + return $ Public.RunProgException str + translateRunResult isBreak (Just (Private.RunGhcException str)) = do + $putStrictMVar isBreak Maybe.nothing + return $ Public.RunGhcException str + translateRunResult isBreak (Just (Private.RunBreak breakInfo)) = do + $putStrictMVar isBreak (Maybe.just breakInfo) + return $ Public.RunBreak + translateRunResult isBreak Nothing = do + -- On a force cancellation we definitely didn't hit a breakpoint + $putStrictMVar isBreak Maybe.nothing + return $ Public.RunForceCancelled + +-- | Breakpoint +-- +-- Set a breakpoint at the specified location. Returns @Just@ the old value of the +-- breakpoint if successful, or @Nothing@ otherwise. +setBreakpoint :: IdeSession + -> ModuleName -- ^ Module where the breakshould should be set + -> Public.SourceSpan -- ^ Location of the breakpoint + -> Bool -- ^ New value for the breakpoint + -> IO (Maybe Bool) -- ^ Old value of the breakpoint (if valid) +setBreakpoint session mod span value = withIdleState session $ \idleState -> + rpcBreakpoint (idleState ^. ideGhcServer) mod span value + +-- | Print and/or force values during debugging +-- +-- Only valid in breakpoint state. +printVar :: IdeSession + -> Public.Name -- ^ Variable to print + -> Bool -- ^ Should printing bind new vars? (@:print@ vs. @:sprint@) + -> Bool -- ^ Should the value be forced? (@:print@ vs. @:force@) + -> IO Public.VariableEnv +printVar session var bind forceEval = withBreakInfo session $ \idleState _ -> + rpcPrint (idleState ^. ideGhcServer) var bind forceEval + +-- TODO: We should do this translation only when we talk to ghc, and keep +-- the original Targets in the session state +-- ** IdeStaticInfo{..} <- asks ideSessionUpdateStaticInfo +-- ** let sourceDir = ideSessionSourceDir ideSessionDir +-- ** newTargets = case targets of +-- ** Public.TargetsInclude l -> +-- ** Public.TargetsInclude $ map (sourceDir ) l +-- ** Public.TargetsExclude l -> +-- ** Public.TargetsExclude $ map (sourceDir ) l +-- ** +-- ** oldTargets <- get ideTargets +-- ** when (oldTargets /= newTargets) $ do +-- ** set ideTargets newTargets +-- ** restartSession' + +{------------------------------------------------------------------------------ + Debugging of ide-backend itself +------------------------------------------------------------------------------} + +-- | Crash the GHC server. For debugging only. If the specified delay is +-- @Nothing@, crash immediately; otherwise, set up a thread that throws +-- an exception to the main thread after the delay. +crashGhcServer :: IdeSession -> Maybe Int -> IO () +crashGhcServer IdeSession{..} delay = $withStrictMVar ideState $ \state -> + case state of + IdeSessionIdle idleState -> + rpcCrash (idleState ^. ideGhcServer) delay + _ -> + Ex.throwIO $ userError "State not idle" + +{------------------------------------------------------------------------------- + Auxiliary (ide-backend specific) +-------------------------------------------------------------------------------} + +withBreakInfo :: IdeSession -> (IdeIdleState -> Public.BreakInfo -> IO a) -> IO a +withBreakInfo session act = withIdleState session $ \idleState -> + case toLazyMaybe (idleState ^. ideBreakInfo) of + Just breakInfo -> act idleState breakInfo + Nothing -> Ex.throwIO (userError "Not in breakpoint state") + +withIdleState :: IdeSession -> (IdeIdleState -> IO a) -> IO a +withIdleState session act = modifyIdleState session $ \idleState -> do + result <- act idleState + return (IdeSessionIdle idleState, result) + +modifyIdleState :: IdeSession -> (IdeIdleState -> IO (IdeSessionState, a)) -> IO a +modifyIdleState IdeSession{..} act = $modifyStrictMVar ideState $ \state -> case state of + IdeSessionIdle idleState -> act idleState + _ -> Ex.throwIO $ userError "State not idle" + +failedToRestart :: ExternalException +failedToRestart = ExternalException { + externalStdErr = "Failed to restart server" + , externalException = Nothing + } + +forcedRestart :: ExternalException +forcedRestart = ExternalException { + externalStdErr = "Session manually restarted" + , externalException = Nothing + } + +serverRestartLoop :: ExternalException +serverRestartLoop = ExternalException { + externalStdErr = "Server restart loop" + , externalException = Nothing + } diff --git a/IdeSession/Update/ExecuteSessionUpdate.hs b/IdeSession/Update/ExecuteSessionUpdate.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Update/ExecuteSessionUpdate.hs @@ -0,0 +1,929 @@ +-- | Execution of session updates +-- +-- Note that we do _NOT_ deal with session restarts here. +-- +-- See comments for IdeSessionUpdate for a motivation of the split between the +-- IdeSessionUpdate type and the ExecuteSessionUpdate type. +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleInstances #-} +module IdeSession.Update.ExecuteSessionUpdate (runSessionUpdate) where + +import Prelude hiding (mod, span) +import Control.Applicative (Applicative, (<$>)) +import Control.Monad (when, void, forM, liftM, filterM) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT, asks) +import Control.Monad.State (MonadState(..)) +import Data.Accessor (Accessor, (.>)) +import Data.Digest.Pure.MD5 (MD5Digest) +import Data.Foldable (forM_) +import Data.Maybe (isJust, catMaybes, fromMaybe) +import Data.Monoid (Monoid(..)) +import System.Exit (ExitCode(..)) +import System.FilePath (makeRelative, (), takeExtension, replaceExtension, dropFileName) +import System.FilePath.Find (find, always, extension, (&&?), (||?), fileType, (==?), FileType (RegularFile)) +import System.Posix.Files (setFileTimes, getFileStatus, modificationTime) +import qualified Control.Exception as Ex +import qualified Data.Accessor.Monad.MTL.State as Acc +import qualified Data.ByteString.Char8 as BSS +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.Text as Text +import qualified System.Directory as Dir + +import IdeSession.Cabal +import IdeSession.Config +import IdeSession.ExeCabalClient (invokeExeCabal) +import IdeSession.GHC.API +import IdeSession.RPC.API (ExternalException) +import IdeSession.State +import IdeSession.Strict.Container +import IdeSession.Strict.IORef (StrictIORef) +import IdeSession.Types.Private hiding (RunResult(..)) +import IdeSession.Types.Progress +import IdeSession.Types.Public (RunBufferMode(..), Targets(..)) +import IdeSession.Update.IdeSessionUpdate +import IdeSession.Util +import qualified IdeSession.GHC.Client as GHC +import qualified IdeSession.Strict.IORef as IORef +import qualified IdeSession.Strict.IntMap as IntMap +import qualified IdeSession.Strict.List as List +import qualified IdeSession.Strict.Map as Map +import qualified IdeSession.Strict.Maybe as Maybe +import qualified IdeSession.Strict.Trie as Trie + +{------------------------------------------------------------------------------- + We execute session updates in a monad in which we have Reader access to + the IdeStaticInfo and the progress back, and State access to the IdeIdleState. + + We do _not_ deal with different IDE states here; that is the responsibility + of updateSession itself. +-------------------------------------------------------------------------------} + +data IdeSessionUpdateEnv = IdeSessionUpdateEnv { + ideUpdateStaticInfo :: IdeStaticInfo + , ideUpdateCallback :: Progress -> IO () + -- For the StateT instance + , ideUpdateStateRef :: StrictIORef IdeIdleState + -- For liftIO + , ideUpdateExceptionRef :: StrictIORef (Maybe ExternalException) + } + +newtype ExecuteSessionUpdate a = ExecuteSessionUpdate { + unwrapUpdate :: ReaderT IdeSessionUpdateEnv IO a + } + deriving ( Functor + , Applicative + , Monad + , MonadReader IdeSessionUpdateEnv + ) + +-- We define MonadState using an IORef rather than StateT so that if an exception +-- happens during the execution of a session update, writes to the state are not +-- lost +instance MonadState IdeIdleState ExecuteSessionUpdate where + get = ExecuteSessionUpdate $ do + stRef <- ideUpdateStateRef <$> ask + liftIO $ IORef.readIORef stRef + + put s = ExecuteSessionUpdate $ do + stRef <- ideUpdateStateRef <$> ask + liftIO $ IORef.writeIORef stRef s + +-- | Kind of like 'liftIO', but with a special treatment for external +-- exceptions. When the IO action throws an ExternalException, _or_ when a +-- previous IO exception threw an ExternalException, we return a dummy value +-- and record the exception separately. Thus, for an action of type +-- +-- > foo :: IO () +-- +-- we will return () on an exception, as if the action returned successfully; +-- similarly, for an action of type +-- +-- > bar :: IO [SourceError] +-- +-- we will return the empty list on an exception. The rationale is that if +-- ExternalException occurs, we will eventually record the session as dead (in +-- the top-level updateSession function), but everything else in the execution +-- of the session update should still happen (#251). +-- +-- NOTE: We deal _only_ with external exceptions here. Any other kind of +-- exception should be explicitly caught and dealt with by the IO action. +tryIO :: Dummy a => IO a -> ExecuteSessionUpdate a +tryIO act = ExecuteSessionUpdate $ do + exRef <- ideUpdateExceptionRef <$> ask + mPreviousException <- liftIO $ IORef.readIORef exRef + case mPreviousException of + Just _ -> + return dummy + Nothing -> do + mNewException <- liftIO $ Ex.try $ act + case mNewException of + Left ex -> do liftIO $ IORef.writeIORef exRef (Just ex) + return dummy + Right a -> return a + +-- | For code that we _know_ is exception free we can just execute the action. +-- Of course, this needs manual verification that these cases are actually okay. +-- If the action _does_ throw an exception this may end the session update +-- prematurely. +exceptionFree :: IO a -> ExecuteSessionUpdate a +exceptionFree = ExecuteSessionUpdate . liftIO + +runSessionUpdate :: Bool + -> IdeSessionUpdate + -> IdeStaticInfo + -> (Progress -> IO ()) + -> IdeIdleState + -> IO (IdeIdleState, Maybe ExternalException) +runSessionUpdate justRestarted update staticInfo callback ideIdleState = do + stRef <- IORef.newIORef ideIdleState + exRef <- IORef.newIORef Nothing + + runReaderT (unwrapUpdate $ executeSessionUpdate justRestarted update') + IdeSessionUpdateEnv { + ideUpdateStaticInfo = staticInfo + , ideUpdateCallback = liftIO . callback + , ideUpdateStateRef = stRef + , ideUpdateExceptionRef = exRef + } + + ideIdleState' <- IORef.readIORef stRef + mException <- IORef.readIORef exRef + return (ideIdleState', mException) + where + update' = reflectSessionState ideIdleState update + +-- | Execute a session update +-- +-- Notes: +-- +-- * We do NOT deal with updates there that require a session restart (updates +-- to relative includes, targets, certain ghc options). +-- * The assume the session update has already been passed through +-- 'reflectSessionState' to reflect the state of the session. +-- * Due to the MonadState instance, writes to the state will be preserved +-- even if an exception occurs during the execution of the session update. +-- Such exceptions should only happen when we contact the server (do RPC +-- calls); it is therefore important we make sure to update our local state +-- before updating the rmote state, so that _if_ a remote exception occurs, +-- we can reset the state on the next call to updateSession. +executeSessionUpdate :: Bool -> IdeSessionUpdate -> ExecuteSessionUpdate () +executeSessionUpdate justRestarted IdeSessionUpdate{..} = do + executeUpdateBufferModes ideUpdateStdoutMode ideUpdateStderrMode + executeUpdateEnv ideUpdateEnv + executeUpdateArgs ideUpdateArgs + + filesChanged <- executeUpdateFiles ideUpdateFileCmds + enabledCodeGen <- executeUpdateCodeGen ideUpdateCodeGen + optionWarnings <- executeUpdateGhcOpts ideUpdateGhcOpts + + -- Unrecord object files whose C files have been deleted (#241) + removeObsoleteObjectFiles + + let ghcOptionsChanged :: Bool + ghcOptionsChanged = isJust optionWarnings + + -- Recompile C files. Notes: + -- + -- - Unless ghc options have changed, we recompile C files only when they + -- have been modified (by comparing the timestamp on the C file to the + -- timestamp on the correponding object file). + -- - We do this _after_ setting ghc because because some ghc options are + -- passed to the C compiler (#218) + -- - Similarly, when the ghc options have changed, we conversatively + -- recompile (and, importantly, relink -- #218) _all_ C files. + (numActions, cErrors) <- updateObjectFiles ghcOptionsChanged + let cFilesChanged :: Bool + cFilesChanged = numActions > 0 + + let needsRecompile = + -- We recompile both when source code and when data files change + -- as we don't know which data files are included at compile time + filesChanged + || -- We need to (re)compile if codegen was just enabled + enabledCodeGen + || -- Changing ghc options might require a recompile + ghcOptionsChanged + -- If any C files changed we may have to recompile Haskell files + || cFilesChanged + -- If we just restarted we have to recompile even if the files + -- didn't change + || justRestarted + + when needsRecompile $ local (incrementNumSteps numActions) $ do + GhcCompileResult{..} <- rpcCompile + oldComputed <- Acc.get ideComputed + srcDir <- asks $ ideSessionSourceDir . ideSessionDir . ideUpdateStaticInfo + + let applyDiff :: Strict (Map ModuleName) (Diff v) + -> (Computed -> Strict (Map ModuleName) v) + -> Strict (Map ModuleName) v + applyDiff diff f = applyMapDiff diff $ Maybe.maybe Map.empty f oldComputed + + let diffSpan = Map.map (fmap mkIdMap) ghcCompileSpanInfo + diffTypes = Map.map (fmap mkExpMap) ghcCompileExpTypes + diffAuto = Map.map (fmap (constructAuto ghcCompileCache)) ghcCompileAuto + + Acc.set ideComputed $ Maybe.just Computed { + computedErrors = force cErrors + List.++ ghcCompileErrors + List.++ force (fromMaybe [] optionWarnings) + , computedLoadedModules = ghcCompileLoaded + , computedFileMap = mkFileMapRelative srcDir ghcCompileFileMap + , computedImports = ghcCompileImports `applyDiff` computedImports + , computedAutoMap = diffAuto `applyDiff` computedAutoMap + , computedSpanInfo = diffSpan `applyDiff` computedSpanInfo + , computedExpTypes = diffTypes `applyDiff` computedExpTypes + , computedUseSites = ghcCompileUseSites `applyDiff` computedUseSites + , computedPkgDeps = ghcCompilePkgDeps `applyDiff` computedPkgDeps + , computedCache = mkCacheRelative srcDir ghcCompileCache + } + + when ideUpdateDocs $ executeBuildDoc + forM_ ideUpdateExes $ uncurry executeBuildExe + forM_ ideUpdateLicenses $ executeBuildLicenses + where + incrementNumSteps :: Int -> IdeSessionUpdateEnv -> IdeSessionUpdateEnv + incrementNumSteps count IdeSessionUpdateEnv{..} = IdeSessionUpdateEnv{ + ideUpdateCallback = \p -> ideUpdateCallback p { + progressStep = progressStep p + count + , progressNumSteps = progressNumSteps p + count + } + , .. + } + + mkCacheRelative :: FilePath -> ExplicitSharingCache -> ExplicitSharingCache + mkCacheRelative srcDir ExplicitSharingCache{..} = + ExplicitSharingCache { + filePathCache = IntMap.map aux filePathCache + , idPropCache = idPropCache + } + where + aux :: BSS.ByteString -> BSS.ByteString + aux = BSS.pack . makeRelative srcDir . BSS.unpack + + mkFileMapRelative :: FilePath -> Strict (Map FilePath) ModuleId -> Strict (Map FilePath) ModuleId + mkFileMapRelative srcDir = Map.mapKeys (makeRelative srcDir) + + constructAuto :: ExplicitSharingCache -> Strict [] IdInfo + -> Strict Trie (Strict [] IdInfo) + constructAuto cache lk = + Trie.fromListWith (List.++) $ map aux (toLazyList lk) + where + aux :: IdInfo -> (BSS.ByteString, Strict [] IdInfo) + aux idInfo@IdInfo{idProp = k} = + let idProp = IntMap.findWithDefault + (error "constructAuto: could not resolve idPropPtr") + (idPropPtr k) + (idPropCache cache) + in ( BSS.pack . Text.unpack . idName $ idProp + , List.singleton idInfo + ) + +-- | Remove context sensitivty from session updates +-- +-- Some updates (such as ideUpdateDeleteFiles) are context sensitive: their +-- meaning depends on the state of the session when the update is performed. +-- For these updates we "reflect" the current state of the session once, just +-- before we execute the update. +reflectSessionState :: IdeIdleState -> IdeSessionUpdate -> IdeSessionUpdate +reflectSessionState IdeIdleState{..} update = mconcat [ + when' (ideUpdateDeleteFiles update) $ mconcat $ + [updateSourceFileDelete (fst m) | m <- _managedSource] + ++ [updateDataFileDelete (fst m) | m <- _managedData] + , update { + ideUpdateDeleteFiles = False + } + ] + where + when' :: forall m. Monoid m => Bool -> m -> m + when' True a = a + when' False _ = mempty + + ManagedFilesInternal{..} = _ideManagedFiles + +{------------------------------------------------------------------------------- + Simple updates +-------------------------------------------------------------------------------} + +-- | Execute file update commands +-- +-- Returns whether any files actually changed. +-- +-- We share the directory where the files are stored with the server, so we +-- don't need to explicitly send over any changed files +executeUpdateFiles :: [FileCmd] -> ExecuteSessionUpdate Bool +executeUpdateFiles fileCmds = or <$> forM fileCmds executeFileCmd + +-- | Enable/disable code gen +-- +-- Returns if code gen was enabled (and wasn't previously) +-- +-- Enabling/disabling code generation has no effect on the server, as we pass +-- this flag on each call to rpcCompile +executeUpdateCodeGen :: Maybe Bool -> ExecuteSessionUpdate Bool +executeUpdateCodeGen = maybeSet ideGenerateCode + +-- | Update buffer modes +-- +-- Updating buffer modes is local only, because we pass the required buffer +-- mode on each and every call to runStmt, rather than setting a server side +-- flag +executeUpdateBufferModes :: Maybe RunBufferMode -> Maybe RunBufferMode -> ExecuteSessionUpdate () +executeUpdateBufferModes stdoutMode stderrMode = do + void $ maybeSet ideStdoutBufferMode stdoutMode + void $ maybeSet ideStderrBufferMode stderrMode + +-- | Update server environment +executeUpdateEnv :: Maybe [(String, Maybe String)] -> ExecuteSessionUpdate () +executeUpdateEnv env = do + changed <- maybeSet ideEnv env + when changed rpcSetEnv + +-- | Update snippet arguments +executeUpdateArgs :: Maybe [String] -> ExecuteSessionUpdate () +executeUpdateArgs args = do + changed <- maybeSet ideArgs args + when changed rpcSetArgs + +-- | Update ghc options +-- +-- Returns Just a (possibly empty) set of a warnings if options were changed, +-- or Nothing otherwise. +-- +-- We don't deal with setting relative includes here: this always requires a +-- session restart; similarly, we assume that if any of the changed options +-- require a session restart that this has already happened. +executeUpdateGhcOpts :: Maybe [String] -> ExecuteSessionUpdate (Maybe [SourceError]) +executeUpdateGhcOpts opts = do + changed <- maybeSet ideGhcOpts opts + if changed then Just <$> rpcSetGhcOpts + else return Nothing + +{------------------------------------------------------------------------------- + Recompile object files +-------------------------------------------------------------------------------} + +-- | Recompile any C files that need recompiling and mark all Haskell modules +-- that require recompilation. +-- +-- Returns the number of actions that were executed, so we can adjust Progress +-- messages returned by ghc. +updateObjectFiles :: Bool -> ExecuteSessionUpdate (Int, [SourceError]) +updateObjectFiles ghcOptionsChanged = do + -- We first figure out which files are updated so that we can number + -- progress messages + outdated <- outdatedObjectFiles ghcOptionsChanged + + if not (null outdated) + then do + -- We first unload all object files in case any symbols need to be + -- re-resolved. + rpcUnloadObjectFiles =<< Acc.get ideObjectFiles + + -- Recompile the C files and load the corresponding object files + cErrors <- recompileCFiles outdated + objErrors <- rpcLoadObjectFiles + + -- Finally, mark Haskell files as updated + -- + -- When C files change, the addresses of the symbols exported in the + -- corresponding object files may change. To make sure that these + -- changes are properly propagated, we unload and reload all object + -- files (so that we reapply symbol resolution, necessary in case the + -- object files refer to each other), and we mark all Haskell modules + -- as updated so that we will recompile them. + -- + -- NOTE: When using HscInterpreted/LinkInMemory C symbols get resolved + -- during compilation, not during a separate linking step. To be + -- precise, they get resolved from deep inside the compiler. Example + -- callchain: + -- + -- > lookupStaticPtr <-- does the resolution + -- > called by generateCCall + -- > called by schemeT + -- > called by schemeE + -- > called by doCase + -- > called by schemeE + -- > called by schemeER_wrk + -- > called by schemeR_wrk + -- > called by schemeR + -- > called by schemeTopBind + -- > called by byteCodeGen + -- > called by hscInteractive + -- + -- Hence, we really need to recompile, rather than just relink. + markAsUpdated $ dependenciesOf outdated + return (length outdated, cErrors ++ objErrors) + else + return (0, []) + where + -- We don't know what the dependencies of the C files are, so we just + -- reload _all_ Haskell modules + dependenciesOf :: [FilePath] -> FilePath -> Bool + dependenciesOf _recompiled src = takeExtension src == ".hs" + +removeObsoleteObjectFiles :: ExecuteSessionUpdate () +removeObsoleteObjectFiles = do + objectFiles <- Acc.get ideObjectFiles + obsolete <- filterM isObsolete objectFiles + forM_ obsolete $ \(cFile, (objFile, _timestamp)) -> do + exceptionFree $ Dir.removeFile objFile + Acc.set (ideObjectFiles .> lookup' cFile) Nothing + rpcUnloadObjectFiles obsolete + where + isObsolete :: (FilePath, (FilePath, LogicalTimestamp)) -> ExecuteSessionUpdate Bool + isObsolete (cFile, _) = do + cInfo <- Acc.get (ideManagedFiles .> managedSource .> lookup' cFile) + return $ not (isJust cInfo) + +recompileCFiles :: [FilePath] -> ExecuteSessionUpdate [SourceError] +recompileCFiles cFiles = do + callback <- asks ideUpdateCallback + sessionDir <- asks $ ideSessionDir . ideUpdateStaticInfo + + let srcDir, objDir :: FilePath + srcDir = ideSessionSourceDir sessionDir + objDir = ideSessionObjDir sessionDir + + errorss <- forM (zip cFiles [1..]) $ \(relC, i) -> do + let relObj = replaceExtension relC ".o" + absC = srcDir relC + absObj = objDir relObj + + let msg = "Compiling " ++ relC + exceptionFree $ callback $ Progress { + progressStep = i + , progressNumSteps = length cFiles + , progressParsedMsg = Just (Text.pack msg) + , progressOrigMsg = Just (Text.pack msg) + } + + exceptionFree $ Dir.createDirectoryIfMissing True (dropFileName absObj) + + errors <- runGcc absC absObj objDir + if null errors + then do + ts' <- updateFileTimes absObj + Acc.set (ideObjectFiles .> lookup' relC) (Just (absObj, ts')) + else do + Acc.set (ideObjectFiles .> lookup' relC) Nothing + + return errors + + return $ concat errorss + +-- | Figure out which C files need to be recompiled +outdatedObjectFiles :: Bool -> ExecuteSessionUpdate [FilePath] +outdatedObjectFiles ghcOptionsChanged = do + IdeStaticInfo{..} <- asks ideUpdateStaticInfo + managedFiles <- Acc.get (ideManagedFiles .> managedSource) + + let cFiles :: [(FilePath, LogicalTimestamp)] + cFiles = filter ((`elem` cExtensions) . takeExtension . fst) + $ map (\(fp, (_, ts)) -> (fp, ts)) + $ managedFiles + + -- If ghc options have changed we consider _all_ C files to be outdated; see + -- comments in executeSessionUpdate. + if ghcOptionsChanged + then return $ map fst cFiles + else liftM catMaybes $ do + forM cFiles $ \(c_fp, c_ts) -> do + -- ideObjectFiles is indexed by the names of the corresponding C files + mObjFile <- Acc.get (ideObjectFiles .> lookup' c_fp) + return $ case mObjFile of + -- No existing object file yet + Nothing -> Just c_fp + -- We _do_ have an existing object file, and it is older than + -- the C file. We need to recompile + Just (_, obj_ts) | obj_ts < c_ts -> Just c_fp + -- Otherwise we don't have to do anything + _ -> Nothing + +-- | Call gcc via ghc, with the same parameters cabal uses. +runGcc :: FilePath -> FilePath -> FilePath -> ExecuteSessionUpdate [SourceError] +runGcc absC absObj pref = do + ideStaticInfo@IdeStaticInfo{..} <- asks ideUpdateStaticInfo + callback <- asks ideUpdateCallback + relIncl <- Acc.get ideRelativeIncludes + + -- Pass GHC options so that ghc can pass the relevant options to gcc + ghcOpts <- Acc.get ideGhcOpts + + let ideDistDir = ideSessionDistDir ideSessionDir + ideSourceDir = ideSessionSourceDir ideSessionDir + + exceptionFree $ do + let SessionConfig{..} = ideConfig + stdoutLog = ideDistDir "ide-backend-cc.stdout" + stderrLog = ideDistDir "ide-backend-cc.stderr" + includeDirs = map (ideSourceDir ) relIncl + runCcArgs = RunCcArgs{ rcPackageDBStack = configPackageDBStack + , rcExtraPathDirs = configExtraPathDirs + , rcDistDir = ideDistDir + , rcStdoutLog = stdoutLog + , rcStderrLog = stderrLog + , rcAbsC = absC + , rcAbsObj = absObj + , rcPref = pref + , rcIncludeDirs = includeDirs + , rcOptions = ghcOpts + } + -- (_exitCode, _stdout, _stderr) + -- <- readProcessWithExitCode _gcc _args _stdin + -- The real deal; we call gcc via ghc via cabal functions: + exitCode <- invokeExeCabal ideStaticInfo (ReqExeCc runCcArgs) callback + stdout <- readFile stdoutLog + stderr <- readFile stderrLog + case exitCode of + ExitSuccess -> return [] + ExitFailure _ -> return (parseErrorMsgs stdout stderr) + where + -- TODO: Parse the error messages returned by gcc. For now, we just + -- return all output as a single, unlocated, error. + parseErrorMsgs :: String -> String -> [SourceError] + parseErrorMsgs stdout stderr = [SourceError + { errorKind = KindError + , errorSpan = TextSpan (Text.pack "") + , errorMsg = Text.pack (stdout ++ stderr) + }] + +-- | Force recompilation of the given modules +-- +-- NOTE: Calling markAsUpdated _by itself_ is not sufficient to call a recompile +-- of these files, as executeSessionUpdate needs some additional information to +-- even ask ghc for a recompile at all (see 'needsRecompile'). Currently we use +-- 'markAsUpdated' after we (re)compile C files, which executeSessionUpdate is +-- told about separately. +-- +-- TODO: Should we update data files here too? +markAsUpdated :: (FilePath -> Bool) -> ExecuteSessionUpdate () +markAsUpdated shouldMark = do + IdeStaticInfo{..} <- asks ideUpdateStaticInfo + sources <- Acc.get (ideManagedFiles .> managedSource) + sources' <- forM sources $ \(path, (digest, oldTS)) -> + if shouldMark path + then do newTS <- updateFileTimes (ideSessionSourceDir ideSessionDir path) + return (path, (digest, newTS)) + else return (path, (digest, oldTS)) + Acc.set (ideManagedFiles .> managedSource) sources' + +{------------------------------------------------------------------------------- + File commands +-------------------------------------------------------------------------------} + +-- | Execute a file command +-- +-- Returns 'True' if any files were changed. +-- +-- TODO: We should verify each use of exceptionFree here. +executeFileCmd :: FileCmd -> ExecuteSessionUpdate Bool +executeFileCmd cmd = do + IdeStaticInfo{..} <- asks ideUpdateStaticInfo + + let remotePath :: FilePath + remotePath = fileInfoRemoteDir info ideSessionDir fileInfoRemoteFile info + + case cmd of + FileWrite _ bs -> do + old <- Acc.get cachedInfo + -- We always overwrite the file, and then later set the timestamp back + -- to what it was if it turns out the hash was the same. If we compute + -- the hash first, we would force the entire lazy bytestring into memory + newHash <- exceptionFree $ writeFileAtomic remotePath bs + case old of + Just (oldHash, oldTS) | oldHash == newHash -> do + exceptionFree $ setFileTimes remotePath oldTS oldTS + return False + _ -> do + newTS <- updateFileTimes remotePath + Acc.set cachedInfo (Just (newHash, newTS)) + return True + FileCopy _ localFile -> do + -- We just call 'FileWrite' because we need to read the file anyway to + -- compute the hash. Note that `localPath` is interpreted relative to the + -- current directory + bs <- exceptionFree $ BSL.readFile localFile + executeFileCmd (FileWrite info bs) + FileDelete _ -> do + exceptionFree $ ignoreDoesNotExist $ Dir.removeFile remotePath + Acc.set cachedInfo Nothing + -- TODO: We should really return True only if the file existed + return True + where + info :: FileInfo + info = case cmd of FileWrite i _ -> i + FileCopy i _ -> i + FileDelete i -> i + + cachedInfo :: Accessor IdeIdleState (Maybe (MD5Digest, LogicalTimestamp)) + cachedInfo = ideManagedFiles .> fileInfoAccessor info .> lookup' (fileInfoRemoteFile info) + +{------------------------------------------------------------------------------- + Executables, documentation, licenses +-------------------------------------------------------------------------------} + +executeBuildExe :: [String] -> [(ModuleName, FilePath)] -> ExecuteSessionUpdate () +executeBuildExe extraOpts ms = do + ideStaticInfo@IdeStaticInfo{..} <- asks ideUpdateStaticInfo + let SessionConfig{..} = ideConfig + let ideDistDir = ideSessionDistDir ideSessionDir + ideSourceDir = ideSessionSourceDir ideSessionDir + + callback <- asks ideUpdateCallback + mcomputed <- Acc.get ideComputed + ghcOpts <- Acc.get ideGhcOpts + relativeIncludes <- Acc.get ideRelativeIncludes + -- Note that these do not contain the @packageDbArgs@ options. + when (not configGenerateModInfo) $ + -- TODO: replace the check with an inspection of state component (#87) + fail "Features using cabal API require configGenerateModInfo, currently (#86)." + exceptionFree $ Dir.createDirectoryIfMissing False $ ideDistDir "build" + let beStdoutLog = ideDistDir "build/ide-backend-exe.stdout" + beStderrLog = ideDistDir "build/ide-backend-exe.stderr" + errors = case toLazyMaybe mcomputed of + Nothing -> + error "This session state does not admit artifact generation." + Just Computed{computedErrors} -> toLazyList computedErrors + exitCode <- + if any (== KindError) $ map errorKind errors then do + exceptionFree $ do + writeFile beStderrLog + "Source or other errors encountered. Not attempting to build executables." + return $ ExitFailure 1 + else do + let ghcOpts' = "-rtsopts=some" : ghcOpts ++ extraOpts + exceptionFree $ do + (loadedMs, pkgs) <- buildDeps mcomputed + libDeps <- externalDeps pkgs + let beArgs = + BuildExeArgs{ bePackageDBStack = configPackageDBStack + , beExtraPathDirs = configExtraPathDirs + , beSourcesDir = ideSourceDir + , beDistDir = ideDistDir + , beRelativeIncludes = relativeIncludes + , beGhcOpts = ghcOpts' + , beLibDeps = libDeps + , beLoadedMs = loadedMs + , beStdoutLog + , beStderrLog + } + invokeExeCabal ideStaticInfo (ReqExeBuild beArgs ms) callback + -- Solution 2. to #119: update timestamps of .o (and all other) files + -- according to the session's artificial timestamp. + newTS <- nextLogicalTimestamp + exceptionFree $ do + objectPaths <- find always + (fileType ==? RegularFile + &&? (extension ==? ".o" + ||? extension ==? ".hi" + ||? extension ==? ".a")) + (ideDistDir "build") + forM_ objectPaths $ \path -> do + fileStatus <- getFileStatus path + -- We only reset the timestamp, if ghc modified the file. + when (modificationTime fileStatus > newTS) $ + setFileTimes path newTS newTS + Acc.set ideBuildExeStatus (Just exitCode) + +executeBuildDoc :: ExecuteSessionUpdate () +executeBuildDoc = do + ideStaticInfo@IdeStaticInfo{..} <- asks ideUpdateStaticInfo + let SessionConfig{..} = ideConfig + let ideDistDir = ideSessionDistDir ideSessionDir + ideSourceDir = ideSessionSourceDir ideSessionDir + + callback <- asks ideUpdateCallback + mcomputed <- Acc.get ideComputed + ghcOpts <- Acc.get ideGhcOpts + relativeIncludes <- Acc.get ideRelativeIncludes + when (not configGenerateModInfo) $ + -- TODO: replace the check with an inspection of state component (#87) + fail "Features using cabal API require configGenerateModInfo, currently (#86)." + exceptionFree $ Dir.createDirectoryIfMissing False $ ideDistDir "doc" + let beStdoutLog = ideDistDir "doc/ide-backend-doc.stdout" + beStderrLog = ideDistDir "doc/ide-backend-doc.stderr" + errors = case toLazyMaybe mcomputed of + Nothing -> + error "This session state does not admit artifact generation." + Just Computed{computedErrors} -> toLazyList computedErrors + isDummyError err = + errorKind err == KindError + && errorMsg err == Text.pack "GHC server died (dummy error)" + exitCode <- + -- If some modules contain source errors we might still want to be able + -- to generate documentation of the remainder. However, we rely on ghc's + -- dependency tracking to tell us _which_ modules we need to compile. + -- If the ghc server died we don't get any dependency information, and + -- would hence conclude that the module graph is empty and generate + -- empty documentation, which is confusing. + -- (Note that a similar situation will arise if the root of the module + -- graph contains source errors, in which case we will also get an + -- empty dependency graph. This is harder to take into account, however.) + if any isDummyError errors then do + exceptionFree $ do + writeFile beStderrLog + "GHC server died. Not attempting to build documentation." + return $ ExitFailure 1 + else exceptionFree $ do + (loadedMs, pkgs) <- buildDeps mcomputed + libDeps <- externalDeps pkgs + let beArgs = + BuildExeArgs{ bePackageDBStack = configPackageDBStack + , beExtraPathDirs = configExtraPathDirs + , beSourcesDir = + makeRelative ideSessionDir ideSourceDir + , beDistDir = + makeRelative ideSessionDir ideDistDir + , beRelativeIncludes = relativeIncludes + , beGhcOpts = ghcOpts + , beLibDeps = libDeps + , beLoadedMs = loadedMs + , beStdoutLog + , beStderrLog + } + invokeExeCabal ideStaticInfo (ReqExeDoc beArgs) callback + Acc.set ideBuildDocStatus (Just exitCode) + +executeBuildLicenses :: FilePath -> ExecuteSessionUpdate () +executeBuildLicenses cabalsDir = do + ideStaticInfo@IdeStaticInfo{..} <- asks ideUpdateStaticInfo + let SessionConfig{configGenerateModInfo} = ideConfig + let ideDistDir = ideSessionDistDir ideSessionDir + + callback <- asks ideUpdateCallback + mcomputed <- Acc.get ideComputed + when (not configGenerateModInfo) $ + -- TODO: replace the check with an inspection of state component (#87) + fail "Features using cabal API require configGenerateModInfo, currently (#86)." + let liStdoutLog = ideDistDir "licenses.stdout" -- progress + liStderrLog = ideDistDir "licenses.stderr" -- warnings and errors + errors = case toLazyMaybe mcomputed of + Nothing -> + error "This session state does not admit artifact generation." + Just Computed{computedErrors} -> toLazyList computedErrors + exitCode <- + if any (== KindError) $ map errorKind errors then do + exceptionFree $ do + writeFile liStderrLog + "Source or other errors encountered. Not attempting to build licenses." + return $ ExitFailure 1 + else exceptionFree $ do + (_, pkgs) <- buildDeps mcomputed + let liArgs = + LicenseArgs{ liPackageDBStack = configPackageDBStack ideConfig + , liExtraPathDirs = configExtraPathDirs ideConfig + , liLicenseExc = configLicenseExc ideConfig + , liDistDir = ideDistDir + , liStdoutLog + , liStderrLog + , licenseFixed = configLicenseFixed ideConfig + , liCabalsDir = cabalsDir + , liPkgs = pkgs + } + invokeExeCabal ideStaticInfo (ReqExeLic liArgs) callback + Acc.set ideBuildLicensesStatus (Just exitCode) + +{------------------------------------------------------------------------------- + Auxiliary (ide-backend specific) +-------------------------------------------------------------------------------} + +-- | Update the file times of the given file with the next logical timestamp +updateFileTimes :: FilePath -> ExecuteSessionUpdate LogicalTimestamp +updateFileTimes path = do + ts <- nextLogicalTimestamp + exceptionFree $ setFileTimes path ts ts + return ts + +-- | Get the next available logical timestamp +nextLogicalTimestamp :: ExecuteSessionUpdate LogicalTimestamp +nextLogicalTimestamp = do + newTS <- Acc.get ideLogicalTimestamp + Acc.modify ideLogicalTimestamp (+ 1) + return newTS + +{------------------------------------------------------------------------------- + Convenience wrappers around the RPC calls +-------------------------------------------------------------------------------} + +rpcCompile :: ExecuteSessionUpdate GhcCompileResult +rpcCompile = do + IdeIdleState{..} <- get + callback <- asks ideUpdateCallback + sourceDir <- asks $ ideSessionSourceDir . ideSessionDir . ideUpdateStaticInfo + + -- We need to translate the targets to absolute paths + let targets = case _ideTargets of + TargetsInclude l -> TargetsInclude $ map (sourceDir ) l + TargetsExclude l -> TargetsExclude $ map (sourceDir ) l + + tryIO $ GHC.rpcCompile _ideGhcServer _ideGenerateCode targets callback + +rpcSetEnv :: ExecuteSessionUpdate () +rpcSetEnv = do + IdeIdleState{..} <- get + tryIO $ GHC.rpcSetEnv _ideGhcServer _ideEnv + +rpcSetArgs :: ExecuteSessionUpdate () +rpcSetArgs = do + IdeIdleState{..} <- get + tryIO $ GHC.rpcSetArgs _ideGhcServer _ideArgs + +rpcSetGhcOpts :: ExecuteSessionUpdate [SourceError] +rpcSetGhcOpts = do + IdeIdleState{..} <- get + srcDir <- asks $ ideSessionSourceDir . ideSessionDir . ideUpdateStaticInfo + -- relative include path is part of the state rather than the + -- config as of c0bf0042 + let relOpts = relInclToOpts srcDir _ideRelativeIncludes + (leftover, warnings) <- tryIO $ GHC.rpcSetGhcOpts _ideGhcServer (_ideGhcOpts ++ relOpts) + return + [ SourceError { + errorKind = KindWarning + , errorSpan = TextSpan (Text.pack "No location information") + , errorMsg = Text.pack w + } + | w <- warnings ++ map unrecognized leftover + ] + where + unrecognized :: String -> String + unrecognized str = "Unrecognized option " ++ show str + +-- | Unload all current object files +rpcUnloadObjectFiles :: [(FilePath, (FilePath, LogicalTimestamp))] -> ExecuteSessionUpdate () +rpcUnloadObjectFiles objects = do + IdeIdleState{..} <- get + tryIO $ GHC.rpcUnload _ideGhcServer $ map (fst . snd) objects + +-- | Reload all current object files +rpcLoadObjectFiles :: ExecuteSessionUpdate [SourceError] +rpcLoadObjectFiles = do + IdeIdleState{..} <- get + didLoad <- tryIO $ GHC.rpcLoad _ideGhcServer $ map (fst . snd) _ideObjectFiles + case didLoad of + Just err -> + return [ SourceError { + errorKind = KindError + , errorSpan = TextSpan (Text.pack "No location information") + , errorMsg = Text.pack $ "Failure during object loading: " ++ err + }] + Nothing -> + return [] + +{------------------------------------------------------------------------------- + Dummy values (see tryIO) +-------------------------------------------------------------------------------} + +class Dummy a where + dummy :: a + +instance Dummy () where + dummy = () +instance Dummy [a] where + dummy = [] +instance (Dummy a, Dummy b) => Dummy (a, b) where + dummy = (dummy, dummy) +instance Dummy (Maybe a) where + dummy = Nothing + +instance Dummy (Strict [] a) where + dummy = List.nil +instance Dummy (Strict (Map k) a) where + dummy = Map.empty +instance Dummy (Strict IntMap a) where + dummy = IntMap.empty + +instance Dummy ExplicitSharingCache where + dummy = ExplicitSharingCache { + filePathCache = dummy + , idPropCache = dummy + } + +instance Dummy GhcCompileResult where + dummy = GhcCompileResult { + ghcCompileLoaded = dummy + , ghcCompileCache = dummy + , ghcCompileFileMap = dummy + , ghcCompileImports = dummy + , ghcCompileAuto = dummy + , ghcCompileSpanInfo = dummy + , ghcCompilePkgDeps = dummy + , ghcCompileExpTypes = dummy + , ghcCompileUseSites = dummy + , ghcCompileErrors = force [SourceError { + errorKind = KindError + , errorSpan = TextSpan (Text.pack "No location information") + , errorMsg = Text.pack "GHC server died (dummy error)" + }] + } + +{------------------------------------------------------------------------------- + Auxiliary (generic) +-------------------------------------------------------------------------------} + +maybeSet :: (MonadState st m, Eq a) => Accessor st a -> Maybe a -> m Bool +maybeSet _ Nothing = return False +maybeSet acc (Just new) = do + old <- Acc.get acc + if old /= new then Acc.set acc new >> return True + else return False diff --git a/IdeSession/Update/IdeSessionUpdate.hs b/IdeSession/Update/IdeSessionUpdate.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Update/IdeSessionUpdate.hs @@ -0,0 +1,382 @@ +-- | Declarative description of session updates +-- +-- We separate the declarative _description_ of a session update from its +-- imperative _execution_. This means that the order in which we execute +-- session updates is independent of the order of the specification, and +-- moreover we can analyze an entire session update to see if we need to +-- restart the s session in order to execute it. +module IdeSession.Update.IdeSessionUpdate ( + -- * Data types describing session updates + IdeSessionUpdate(..) + , FileInfo(..) + , FileCmd(..) + -- * Individual updates + , updateDeleteManagedFiles + , updateSourceFile + , updateSourceFileFromFile + , updateSourceFileDelete + , updateDataFile + , updateDataFileFromFile + , updateDataFileDelete + , updateGhcOpts + , updateRtsOpts + , updateRelativeIncludes + , updateCodeGeneration + , updateEnv + , updateArgs + , updateStdoutBufferMode + , updateStderrBufferMode + , updateTargets + , buildExe + , buildDoc + , buildLicenses + ) where + +import Prelude hiding (mod, span) +import Control.Monad (mplus) +import Data.Accessor (Accessor) +import Data.Monoid (Monoid(..)) +import qualified Data.ByteString.Lazy.Char8 as BSL + +import IdeSession.GHC.API +import IdeSession.State +import IdeSession.Types.Private hiding (RunResult(..)) +import IdeSession.Types.Public (RunBufferMode(..)) +import qualified IdeSession.Types.Public as Public + +{------------------------------------------------------------------------------- + Data types +-------------------------------------------------------------------------------} + +-- | Declarative description of session updates +-- +-- IdeSessionUpdate forms a monoid, which is right-biased: "later" calls +-- override "earlier" ones: +-- +-- > updateTargets targets1 <> updateTargets2 +-- +-- is equivalent to +-- +-- > updateTargets2 +-- +-- However, updates of a different nature are not necessarily executed in order; +-- for instance, +-- +-- > updateDynamicOpts opts <> updateSourceFile fp bs +-- +-- is equivalent to +-- +-- > updateSourceFile fp bs <> updateDynamicOpts opts +-- +-- In both cases options are set before new source files are compiled. +-- +-- File commands are updated in order, so that +-- +-- > updateSourceFile fp bs <> updateSourceFile fp bs' +-- +-- is equivalent to +-- +-- > updateSourceFile fp bs' +-- +-- which is consistent with "later updates override earlier ones". +data IdeSessionUpdate = IdeSessionUpdate { + ideUpdateFileCmds :: [FileCmd] + , ideUpdateDeleteFiles :: Bool + , ideUpdateGhcOpts :: Maybe [String] + , ideUpdateRelIncls :: Maybe [FilePath] + , ideUpdateCodeGen :: Maybe Bool + , ideUpdateEnv :: Maybe [(String, Maybe String)] + , ideUpdateArgs :: Maybe [String] + , ideUpdateStdoutMode :: Maybe RunBufferMode + , ideUpdateStderrMode :: Maybe RunBufferMode + , ideUpdateTargets :: Maybe Public.Targets + , ideUpdateExes :: [([String], [(ModuleName, FilePath)])] + , ideUpdateDocs :: Bool + , ideUpdateLicenses :: [FilePath] + , ideUpdateRtsOpts :: Maybe [String] + } + deriving Show + +instance Monoid IdeSessionUpdate where + mempty = IdeSessionUpdate { + ideUpdateFileCmds = [] + , ideUpdateDeleteFiles = False + , ideUpdateGhcOpts = Nothing + , ideUpdateRelIncls = Nothing + , ideUpdateCodeGen = Nothing + , ideUpdateEnv = Nothing + , ideUpdateArgs = Nothing + , ideUpdateStdoutMode = Nothing + , ideUpdateStderrMode = Nothing + , ideUpdateTargets = Nothing + , ideUpdateExes = [] + , ideUpdateDocs = False + , ideUpdateLicenses = [] + , ideUpdateRtsOpts = Nothing + } + + a `mappend` b = IdeSessionUpdate { + -- File and builds commands are executed in order + ideUpdateFileCmds = ideUpdateFileCmds a ++ ideUpdateFileCmds b + , ideUpdateExes = ideUpdateExes a ++ ideUpdateExes b + , ideUpdateLicenses = ideUpdateLicenses a ++ ideUpdateLicenses b + + -- For boolean options we just take logical disjunction + , ideUpdateDeleteFiles = ideUpdateDeleteFiles a || ideUpdateDeleteFiles b + , ideUpdateDocs = ideUpdateDocs a || ideUpdateDocs b + + -- Everything else is right biased (see comments for IdeSessionUpdate) + , ideUpdateGhcOpts = ideUpdateGhcOpts b `mplus` ideUpdateGhcOpts a + , ideUpdateRelIncls = ideUpdateRelIncls b `mplus` ideUpdateRelIncls a + , ideUpdateCodeGen = ideUpdateCodeGen b `mplus` ideUpdateCodeGen a + , ideUpdateEnv = ideUpdateEnv b `mplus` ideUpdateEnv a + , ideUpdateArgs = ideUpdateArgs b `mplus` ideUpdateArgs a + , ideUpdateStdoutMode = ideUpdateStdoutMode b `mplus` ideUpdateStdoutMode a + , ideUpdateStderrMode = ideUpdateStderrMode b `mplus` ideUpdateStderrMode a + , ideUpdateTargets = ideUpdateTargets b `mplus` ideUpdateTargets a + , ideUpdateRtsOpts = ideUpdateRtsOpts b `mplus` ideUpdateRtsOpts a + } + +data FileInfo = FileInfo { + fileInfoRemoteDir :: FilePath -> FilePath + , fileInfoRemoteFile :: FilePath + , fileInfoAccessor :: Accessor ManagedFilesInternal [ManagedFile] + } + +instance Show FileInfo where + show (FileInfo{..}) = "<>" + +data FileCmd = + -- | Write a file from a bytestring + FileWrite FileInfo BSL.ByteString + + -- | Copy a local file (the FilePath is interpreted as an absolute path) + | FileCopy FileInfo FilePath + + -- | Delete a file + | FileDelete FileInfo + deriving Show + +{------------------------------------------------------------------------------- + Individual updates +-------------------------------------------------------------------------------} + +-- | Delete all files currently managed in this session +updateDeleteManagedFiles :: IdeSessionUpdate +updateDeleteManagedFiles = mempty { ideUpdateDeleteFiles = True } + +-- | A session update that changes a source file by providing some contents. +-- This can be used to add a new module or update an existing one. +-- The @FilePath@ argument determines the directory +-- and file where the module is located within the project. +-- In case of Haskell source files, the actual internal +-- compiler module name, such as the one given by the +-- @getLoadedModules@ query, comes from within @module ... end@. +-- Usually the two names are equal, but they needn't be. +updateSourceFile :: FilePath -> BSL.ByteString -> IdeSessionUpdate +updateSourceFile fp bs = mempty { ideUpdateFileCmds = [FileWrite fileInfo bs] } + where + fileInfo = FileInfo { + fileInfoRemoteFile = fp + , fileInfoRemoteDir = ideSessionSourceDir + , fileInfoAccessor = managedSource + } + +-- | Like 'updateSourceFile' except that instead of passing the source by +-- value, it's given by reference to an existing file, which will be copied. +updateSourceFileFromFile :: FilePath -> IdeSessionUpdate +updateSourceFileFromFile fp = mempty { ideUpdateFileCmds = [FileCopy fileInfo fp] } + where + fileInfo = FileInfo { + fileInfoRemoteFile = fp + , fileInfoRemoteDir = ideSessionSourceDir + , fileInfoAccessor = managedSource + } + +-- | A session update that deletes an existing source file. +updateSourceFileDelete :: FilePath -> IdeSessionUpdate +updateSourceFileDelete fp = mempty { ideUpdateFileCmds = [FileDelete fileInfo] } + where + fileInfo = FileInfo { + fileInfoRemoteFile = fp + , fileInfoRemoteDir = ideSessionSourceDir + , fileInfoAccessor = managedSource + } + +-- | A session update that changes a data file by giving a new value for the +-- file. This can be used to add a new file or update an existing one. +updateDataFile :: FilePath -> BSL.ByteString -> IdeSessionUpdate +updateDataFile fp bs = mempty { ideUpdateFileCmds = [FileWrite fileInfo bs] } + where + fileInfo = FileInfo { + fileInfoRemoteFile = fp + , fileInfoRemoteDir = ideSessionDataDir + , fileInfoAccessor = managedData + } + +-- | Like 'updateDataFile' except that instead of passing the file content by +-- value, it's given by reference to an existing file (the second argument), +-- which will be copied. +updateDataFileFromFile :: FilePath -> FilePath -> IdeSessionUpdate +updateDataFileFromFile remoteFile localFile = mempty { + ideUpdateFileCmds = [FileCopy fileInfo localFile] + } + where + fileInfo = FileInfo { + fileInfoRemoteFile = remoteFile + , fileInfoRemoteDir = ideSessionDataDir + , fileInfoAccessor = managedData + } + +-- | Deletes an existing data file. +-- +updateDataFileDelete :: FilePath -> IdeSessionUpdate +updateDataFileDelete fp = mempty { ideUpdateFileCmds = [FileDelete fileInfo] } + where + fileInfo = FileInfo { + fileInfoRemoteFile = fp + , fileInfoRemoteDir = ideSessionDataDir + , fileInfoAccessor = managedData + } + +-- | Set ghc options +-- +-- This function is stateless: the set of actions options is the set provided +-- by the last call to updateGhcOptions. +updateGhcOpts :: [String] -> IdeSessionUpdate +updateGhcOpts opts = mempty { ideUpdateGhcOpts = Just opts } + +-- | Set RTS options for the ghc session (this does not affect executables) +-- +-- This will cause a session restart. +-- +-- NOTE: Limiting stack size does not seem to work for ghc 7.4 +-- (https://github.com/fpco/ide-backend/issues/258). +updateRtsOpts :: [String] -> IdeSessionUpdate +updateRtsOpts opts = mempty { ideUpdateRtsOpts = Just opts } + +-- | Set include paths (equivalent of GHC's @-i@ parameter). +-- In general, this requires session restart, +-- because GHC doesn't revise module dependencies when targets +-- or include paths change, but only when files change. +-- +-- This function is stateless: semantically, the set of currently active +-- include paths are those set in the last call to updateRelativeIncludes. +-- Any paths set earlier (including those from 'configRelativeIncludes') +-- are wiped out and overwritten in each call to updateRelativeIncludes. +updateRelativeIncludes :: [FilePath] -> IdeSessionUpdate +updateRelativeIncludes relIncl = mempty { ideUpdateRelIncls = Just relIncl } + +-- | Enable or disable code generation in addition +-- to type-checking. Required by 'runStmt'. +updateCodeGeneration :: Bool -> IdeSessionUpdate +updateCodeGeneration b = mempty { ideUpdateCodeGen = Just b } + +-- | Set environment variables +-- +-- Use @updateEnv [(var, Nothing)]@ to unset @var@. +-- +-- Note that this is intended to be stateless: +-- +-- > updateEnv [] +-- +-- will reset the environment to the server's original environment. +updateEnv :: [(String, Maybe String)] -> IdeSessionUpdate +updateEnv overrides = mempty { ideUpdateEnv = Just overrides } + +-- | Set command line arguments for snippets +-- (i.e., the expected value of `getArgs`) +updateArgs :: [String] -> IdeSessionUpdate +updateArgs args = mempty { ideUpdateArgs = Just args } + +-- | Set buffering mode for snippets' stdout +updateStdoutBufferMode :: RunBufferMode -> IdeSessionUpdate +updateStdoutBufferMode m = mempty { ideUpdateStdoutMode = Just m } + +-- | Set buffering mode for snippets' stderr +updateStderrBufferMode :: RunBufferMode -> IdeSessionUpdate +updateStderrBufferMode m = mempty { ideUpdateStderrMode = Just m } + +-- | Set compilation targets. In general, this requires session restart, +-- because GHC doesn't revise module dependencies when targets +-- or include paths change, but only when files change. +updateTargets :: Public.Targets -> IdeSessionUpdate +updateTargets targets = mempty { ideUpdateTargets = Just targets } + +-- | Build an exe from sources added previously via the ide-backend +-- updateSourceFile* mechanism. The modules that contains the @main@ code are +-- indicated in second argument to @buildExe@. The function can be called +-- multiple times with different arguments. Additional GHC options, +-- applied only when building executables, are supplied in the first argument. +-- +-- We assume any indicated module is already successfully processed by GHC API +-- in a compilation mode that makes @computedImports@ available (but no code +-- needs to be generated). The environment (package dependencies, ghc options, +-- preprocessor program options, etc.) for building the exe is the same as when +-- previously compiling the code via GHC API. The module does not have to be +-- called @Main@, but we assume the main function is always @main@ (we don't +-- check this and related conditions, but GHC does when eventually called to +-- build the exe). +-- +-- The executable files are placed in the filesystem inside the @build@ +-- subdirectory of 'Query.getDistDir', in subdirectories corresponding +-- to the given module names. The build directory does not overlap +-- with any of the other used directories and with its path. +-- +-- Logs from the building process are saved in files +-- @build\/ide-backend-exe.stdout@ and @build\/ide-backend-exe.stderr@ +-- in the 'Query.getDistDir' directory. +-- +-- Note: currently it requires @configGenerateModInfo@ to be set (see #86). +-- Also, after session restart, one has to call @updateSession@ at least once +-- (even with empty updates list) before calling it for @buildExe@. +-- This ensures the code is compiled again and the results made accessible. +buildExe :: [String] -> [(ModuleName, FilePath)] -> IdeSessionUpdate +buildExe extraOpts ms = mempty { ideUpdateExes = [(extraOpts, ms)] } + +-- | Build haddock documentation from sources added previously via +-- the ide-backend updateSourceFile* mechanism. Similarly to 'buildExe', +-- it needs the project modules to be already loaded within the session +-- and the generated docs can be found in the @doc@ subdirectory +-- of 'Query.getDistDir'. +-- +-- Logs from the documentation building process are saved in files +-- @doc\/ide-backend-doc.stdout@ and @doc\/ide-backend-doc.stderr@ +-- in the 'Query.getDistDir' directory. +-- +-- Note: currently it requires @configGenerateModInfo@ to be set (see #86). +buildDoc :: IdeSessionUpdate +buildDoc = mempty { ideUpdateDocs = True } + +-- | Build a file containing licenses of all used packages. +-- Similarly to 'buildExe', the function needs the project modules to be +-- already loaded within the session. The concatenated licenses can be found +-- in file @licenses.txt@ inside the 'Query.getDistDir' directory. +-- +-- The function expects .cabal files of all used packages, +-- except those mentioned in 'configLicenseExc', +-- to be gathered in the directory given as the first argument +-- (which needs to be an absolute path or a path relative to the data dir). +-- The code then expects to find those packages installed and their +-- license files in the usual place that Cabal puts them +-- (or the in-place packages should be correctly embedded in the GHC tree). +-- +-- We guess the installed locations of the license files on the basis +-- of the haddock interfaces path. If the default setting does not work +-- properly, the haddock interfaces path should be set manually. E.g., +-- @cabal configure --docdir=the_same_path --htmldir=the_same_path@ +-- affects the haddock interfaces path (because it is by default based +-- on htmldir) and is reported to work for some values of @the_same_path@. +-- +-- Logs from the license search and catenation process are saved in files +-- @licenses.stdout@ and @licenses.stderr@ +-- in the 'Query.getDistDir' directory. +-- +-- Note: currently 'configGenerateModInfo' needs to be set +-- for this function to work (see #86). +-- +-- Note: if the executable uses TH and its module is named @Main@ +-- (and so it's not compiled as a part of a temporary library) +-- 'Config.configDynLink' needs to be set. See #162. +buildLicenses :: FilePath -> IdeSessionUpdate +buildLicenses cabalsDir = mempty { ideUpdateLicenses = [cabalsDir] } diff --git a/IdeSession/Util.hs b/IdeSession/Util.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Util.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, DeriveFunctor, DeriveGeneric, StandaloneDeriving, GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module IdeSession.Util ( + -- * Misc util + showExWithClass + , accessorName + , lookup' + , envWithPathOverride + , writeFileAtomic + , setupEnv + , relInclToOpts + , parseProgressMessage + , ignoreDoesNotExist + , interruptible + -- * Simple diffs + , Diff(..) + , applyMapDiff + -- * Manipulating stdout and stderr + , swizzleStdout + , swizzleStderr + , redirectStderr + , captureOutput + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (void, forM_, mplus) +import Crypto.Classes (blockLength, initialCtx, updateCtx, finalize) +import Crypto.Types (BitLength) +import Data.Accessor (Accessor, accessor) +import Data.Binary (Binary(..)) +import Data.Char (isSpace) +import Data.Digest.Pure.MD5 (MD5Digest, MD5Context) +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.Tagged (Tagged, untag) +import Data.Text (Text) +import Data.Typeable (typeOf) +import Foreign.C.Types (CFile) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import GHC.Generics (Generic) +import GHC.IO (unsafeUnmask) +import System.Directory (createDirectoryIfMissing, removeFile, renameFile) +import System.Environment (getEnvironment) +import System.FilePath (splitFileName, (<.>), ()) +import System.FilePath (splitSearchPath, searchPathSeparator) +import System.IO +import System.IO.Error (isDoesNotExistError) +import System.IO.Temp (withSystemTempFile) +import System.Posix (Fd) +import System.Posix.Env (setEnv, unsetEnv) +import System.Posix.IO +import System.Posix.Types (CPid(..)) +import Text.Show.Pretty +import qualified Control.Exception as Ex +import qualified Data.Attoparsec.Text as Att +import qualified Data.Binary as Bin +import qualified Data.Binary.Builder.Internal as Bin (writeN) +import qualified Data.Binary.Get.Internal as Bin (readNWith) +import qualified Data.Binary.Put as Bin (putBuilder) +import qualified Data.ByteString as BSS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as Text +import qualified Data.Text.Foreign as Text +import qualified System.Posix.Files as Files + +import IdeSession.Strict.Container +import qualified IdeSession.Strict.Map as StrictMap + +foreign import ccall "fflush" fflush :: Ptr CFile -> IO () + +{------------------------------------------------------------------------------ + Util +------------------------------------------------------------------------------} + +-- | Show an exception together with its most precise type tag. +showExWithClass :: Ex.SomeException -> String +showExWithClass (Ex.SomeException ex) = show (typeOf ex) ++ ": " ++ show ex + +-- | Translate record field '_name' to the accessor 'name' +accessorName :: String -> Maybe String +accessorName ('_' : str) = Just str +accessorName _ = Nothing + +-- | Prelude.lookup as an accessor +lookup' :: Eq a => a -> Accessor [(a, b)] (Maybe b) +lookup' key = + accessor (lookup key) $ \mVal list -> + case mVal of + Nothing -> delete key list + Just val -> override key val list + where + override :: Eq a => a -> b -> [(a, b)] -> [(a, b)] + override a b [] = [(a, b)] + override a b ((a', b') : xs) + | a == a' = (a, b) : xs + | otherwise = (a', b') : override a b xs + + delete :: Eq a => a -> [(a, b)] -> [(a, b)] + delete _ [] = [] + delete a ((a', b') : xs) + | a == a' = xs + | otherwise = (a', b') : delete a xs + +envWithPathOverride :: [FilePath] -> IO (Maybe [(String, String)]) +envWithPathOverride [] = return Nothing +envWithPathOverride extraPathDirs = do + env <- getEnvironment + let path = fromMaybe "" (lookup "PATH" env) + path' = intercalate [searchPathSeparator] + (extraPathDirs ++ splitSearchPath path) + env' = ("PATH", path') : filter (\(var, _) -> var /= "PATH") env + return (Just env') + +-- | Writes a file atomically. +-- +-- The file is either written successfully or an IO exception is raised and +-- the original file is left unchanged. +-- +-- On windows it is not possible to delete a file that is open by a process. +-- This case will give an IO exception but the atomic property is not affected. +-- +-- Returns the hash of the file; we are careful not to force the entire input +-- bytestring into memory (we compute the hash as we write the file). +writeFileAtomic :: FilePath -> BSL.ByteString -> IO MD5Digest +writeFileAtomic targetPath content = do + let (targetDir, targetFile) = splitFileName targetPath + createDirectoryIfMissing True targetDir + Ex.bracketOnError + (openBinaryTempFile targetDir $ targetFile <.> "tmp") + (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) + (\(tmpPath, handle) -> do + let bits :: Tagged MD5Digest BitLength ; bits = blockLength + hash <- go handle initialCtx $ makeBlocks (untag bits `div` 8) content + hClose handle + renameFile tmpPath targetPath + return hash) + where + go :: Handle -> MD5Context -> [BSS.ByteString] -> IO MD5Digest + go _ _ [] = error "Bug in makeBlocks" + go h ctx [bs] = BSS.hPut h bs >> return (finalize ctx bs) + go h ctx (bs:bss) = BSS.hPut h bs >> go h (updateCtx ctx bs) bss + +-- | @makeBlocks n@ splits a bytestring into blocks with a size that is a +-- multiple of 'n', with one left-over smaller bytestring at the end. +-- +-- Based from the (unexported) 'makeBlocks' in the crypto-api package, but +-- we are careful to be as lazy as possible (the first -- block can be returned +-- before the entire input bytestring is forced) +makeBlocks :: Int -> BSL.ByteString -> [BSS.ByteString] +makeBlocks n = go . BSL.toChunks + where + go [] = [BSS.empty] + go (bs:bss) + | BSS.length bs >= n = + let l = BSS.length bs - (BSS.length bs `rem` n) + (bsInit, bsTail) = BSS.splitAt l bs + in bsInit : go (bsTail : bss) + | otherwise = + case bss of + [] -> [bs] + (bs':bss') -> go (BSS.append bs bs' : bss') + +-- | First restore the environment to the specified initial environment, then +-- apply the given overrides +setupEnv :: [(String, String)] -> [(String, Maybe String)] -> IO () +setupEnv initEnv overrides = do + -- Delete everything in the current environment + curEnv <- getEnvironment + forM_ curEnv $ \(var, _val) -> unsetEnv var + + -- Restore initial environment + forM_ initEnv $ \(var, val) -> setEnv var val True + + -- Apply overrides + forM_ overrides $ \(var, mVal) -> + case mVal of + Just val -> setEnv var val True + Nothing -> unsetEnv var + +relInclToOpts :: FilePath -> [FilePath] -> [String] +relInclToOpts sourcesDir relIncl = + ["-i"] -- reset to empty + ++ map (\path -> "-i" ++ sourcesDir path) relIncl + +parseProgressMessage :: Text -> Either String (Int, Int, Text) +parseProgressMessage = Att.parseOnly parser + where + parser :: Att.Parser (Int, Int, Text) + parser = do + _ <- Att.char '[' ; Att.skipSpace + step <- Att.decimal ; Att.skipSpace + _ <- Att.string (Text.pack "of") ; Att.skipSpace + numS <- Att.decimal ; Att.skipSpace + _ <- Att.char ']' ; Att.skipSpace + rest <- parseCompiling `mplus` Att.takeText + return (step, numS, rest) + + parseCompiling :: Att.Parser Text + parseCompiling = do + compiling <- Att.string (Text.pack "Compiling") ; Att.skipSpace + _ <- parseTH ; Att.skipSpace + modName <- Att.takeTill isSpace + return $ Text.concat [compiling, Text.pack " ", modName] + + parseTH :: Att.Parser () + parseTH = Att.option () $ void $ Att.string (Text.pack "[TH]") + +-- | Ignore "does not exist" exception +ignoreDoesNotExist :: IO () -> IO () +ignoreDoesNotExist = Ex.handle $ \e -> + if isDoesNotExistError e then return () + else Ex.throwIO e + +-- | Define interruptiple operations +-- +-- (TODO: Stick in reference to blog post) +interruptible :: IO a -> IO a +interruptible act = do + st <- Ex.getMaskingState + case st of + Ex.Unmasked -> act + Ex.MaskedInterruptible -> unsafeUnmask act + Ex.MaskedUninterruptible -> act + +{------------------------------------------------------------------------------ + Simple diffs +------------------------------------------------------------------------------} + +data Diff a = Keep | Remove | Insert a + deriving (Show, Functor, Generic) + +instance Binary a => Binary (Diff a) where + put Keep = Bin.putWord8 0 + put Remove = Bin.putWord8 1 + put (Insert a) = Bin.putWord8 2 >> Bin.put a + + get = do + header <- Bin.getWord8 + case header of + 0 -> return Keep + 1 -> return Remove + 2 -> Insert <$> Bin.get + _ -> fail "Diff.get: invalid header" + +instance PrettyVal a => PrettyVal (Diff a) -- relies on Generics + +applyMapDiff :: forall k v. Ord k + => Strict (Map k) (Diff v) + -> Strict (Map k) v -> Strict (Map k) v +applyMapDiff diff = foldr (.) id (map aux $ StrictMap.toList diff) + where + aux :: (k, Diff v) -> Strict (Map k) v -> Strict (Map k) v + aux (_, Keep) = id + aux (k, Remove) = StrictMap.delete k + aux (k, Insert x) = StrictMap.insert k x + +{------------------------------------------------------------------------------- + Manipulations with stdout and stderr. +-------------------------------------------------------------------------------} + +swizzleStdout :: Fd -> IO a -> IO a +swizzleStdout = swizzleHandle (stdout, stdOutput) + +swizzleStderr :: Fd -> IO a -> IO a +swizzleStderr = swizzleHandle (stderr, stdError) + +swizzleHandle :: (Handle, Fd) -> Fd -> IO a -> IO a +swizzleHandle (targetHandle, targetFd) fd act = + Ex.bracket swizzle unswizzle (\_ -> act) + where + swizzle :: IO Fd + swizzle = do + -- Flush existing handles + hFlush targetHandle + fflush nullPtr + + -- Backup stdout, then replace stdout with the given fd + backup <- dup targetFd + _ <- dupTo fd targetFd + + return backup + + unswizzle :: Fd -> IO () + unswizzle backup = do + -- Flush handles again + hFlush targetHandle + fflush nullPtr + + -- Restore stdout + _ <- dupTo backup targetFd + closeFd backup + +redirectStderr :: FilePath -> IO a -> IO a +redirectStderr fp act = do + Ex.bracket (openFd fp WriteOnly (Just mode) defaultFileFlags) + closeFd $ \errorLogFd -> + swizzleStderr errorLogFd $ + act + where + mode = Files.unionFileModes Files.ownerReadMode Files.ownerWriteMode + +captureOutput :: IO a -> IO (String, a) +captureOutput act = do + withSystemTempFile "suppressed" $ \fp handle -> do + fd <- handleToFd handle + a <- swizzleStdout fd . swizzleStderr fd $ act + closeFd fd + suppressed <- readFile fp + return (suppressed, a) + +{------------------------------------------------------------------------------- + Orphans +-------------------------------------------------------------------------------} + +instance Binary Text where + get = do units <- Bin.get + Bin.readNWith (units * 2) $ \ptr -> + Text.fromPtr (castPtr ptr) (fromIntegral units) + + put t = do put (Text.lengthWord16 t) + Bin.putBuilder $ + Bin.writeN (Text.lengthWord16 t * 2) + (\p -> Text.unsafeCopyToPtr t (castPtr p)) + +deriving instance Binary CPid diff --git a/IdeSession/Util/BlockingOps.hs b/IdeSession/Util/BlockingOps.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Util/BlockingOps.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE CPP, TemplateHaskell, NamedFieldPuns #-} +-- | Blocking operations such as +-- +-- > readMVar v +-- +-- may throw an exception such as +-- +-- > thread blocked indefinitely in an MVar operation +-- +-- Unfortunately, this exception does not give any information of _where_ in +-- the code we are blocked indefinitely. Compiling with profiling info and +-- running with +RTC -xc can address this to some extent, but (1) it requires +-- that all profiling libraries are installed and (2) when we are running +-- multithreaded code the resulting stack trace is often difficult to read +-- (and still does not include line numbers). With this module you can replace +-- the above code with +-- +-- > $readMVar v +-- +-- and the exception that will be thrown is +-- +-- > YourModule:lineNumber: thread blocked indefinitely in an MVar operation +-- +-- which is a lot more informative. When the CPP flag DEBUGGING is turned off +-- then @$readMVar@ just turns into @readMVar@. +-- +-- NOTE: The type of the exception changes when using DEBUGGING mode -- in order +-- to be able to add the line number, all exceptions are turned into +-- IOExceptions. +module IdeSession.Util.BlockingOps ( + -- * Generic debugging utilities + lineNumber + , traceOnException + , mapExceptionIO + , mapExceptionShow + -- * Blocking MVar ops + , putMVar + , takeMVar + , modifyMVar + , modifyMVar_ + , withMVar + , readMVar + , swapMVar + -- * Same for strict MVars + , putStrictMVar + , takeStrictMVar + , modifyStrictMVar + , modifyStrictMVar_ + , withStrictMVar + , readStrictMVar + , swapStrictMVar + -- * Blocking Chan ops + , readChan + -- * Blocking Async ops + , wait + , waitCatch + , waitAny + , waitAnyCatchCancel + ) where + +import Language.Haskell.TH +import qualified Control.Concurrent as C +import qualified Control.Concurrent.Async as Async +import System.IO (hPutStrLn, stderr) +import qualified Control.Exception as Ex + +import qualified IdeSession.Strict.MVar as StrictMVar + +lineNumber :: ExpQ +lineNumber = do + Loc{loc_module, loc_start=(line, _)} <- location + [| loc_module ++ ":" ++ show (line :: Int) |] + +mapExceptionIO :: (Ex.Exception e1, Ex.Exception e2) + => (e1 -> e2) -> IO a -> IO a +mapExceptionIO f io = Ex.catch io (Ex.throwIO . f) + +mapExceptionShow :: (String -> String) -> IO a -> IO a +mapExceptionShow f = mapExceptionIO (userError . f . showSomeException) + where + showSomeException :: Ex.SomeException -> String + showSomeException = show + +traceOnException :: String -> IO a -> IO a +traceOnException str io = Ex.catch io $ \e -> do + hPutStrLn stderr (str ++ ": " ++ show e) + Ex.throwIO (e :: Ex.SomeException) + +#define DEBUGGING 0 + +#if DEBUGGING == 1 + +rethrowWithLineNumber1 :: ExpQ -> ExpQ +rethrowWithLineNumber1 expr = + [| \arg1 -> mapExceptionShow (\e -> $lineNumber ++ ": " ++ e) + ($expr arg1) + |] + +rethrowWithLineNumber2 :: ExpQ -> ExpQ +rethrowWithLineNumber2 expr = + [| \arg1 arg2 -> mapExceptionShow (\e -> $lineNumber ++ ": " ++ e) + ($expr arg1 arg2) + |] + +{------------------------------------------------------------------------------- + MVar +-------------------------------------------------------------------------------} + +takeMVar :: ExpQ +takeMVar = rethrowWithLineNumber1 [| C.takeMVar |] + +putMVar :: ExpQ +putMVar = rethrowWithLineNumber2 [| C.putMVar |] + +readMVar :: ExpQ +readMVar = rethrowWithLineNumber1 [| C.readMVar |] + +modifyMVar :: ExpQ +modifyMVar = rethrowWithLineNumber2 [| C.modifyMVar |] + +modifyMVar_ :: ExpQ +modifyMVar_ = rethrowWithLineNumber2 [| C.modifyMVar_ |] + +withMVar :: ExpQ +withMVar = rethrowWithLineNumber2 [| C.withMVar |] + +swapMVar :: ExpQ +swapMVar = rethrowWithLineNumber2 [| C.swapMVar |] + +{------------------------------------------------------------------------------- + StrictMVar +-------------------------------------------------------------------------------} + +takeStrictMVar :: ExpQ +takeStrictMVar = rethrowWithLineNumber1 [| StrictMVar.takeMVar |] + +putStrictMVar :: ExpQ +putStrictMVar = rethrowWithLineNumber2 [| StrictMVar.putMVar |] + +readStrictMVar :: ExpQ +readStrictMVar = rethrowWithLineNumber1 [| StrictMVar.readMVar |] + +modifyStrictMVar :: ExpQ +modifyStrictMVar = rethrowWithLineNumber2 [| StrictMVar.modifyMVar |] + +modifyStrictMVar_ :: ExpQ +modifyStrictMVar_ = rethrowWithLineNumber2 [| StrictMVar.modifyMVar_ |] + +withStrictMVar :: ExpQ +withStrictMVar = rethrowWithLineNumber2 [| StrictMVar.withMVar |] + +swapStrictMVar :: ExpQ +swapStrictMVar = rethrowWithLineNumber2 [| StrictMVar.swapMVar |] + +{------------------------------------------------------------------------------- + Chan +-------------------------------------------------------------------------------} + +readChan :: ExpQ +readChan = rethrowWithLineNumber1 [| C.readChan |] + +{------------------------------------------------------------------------------- + Async +-------------------------------------------------------------------------------} + +wait :: ExpQ +wait = rethrowWithLineNumber1 [| Async.wait |] + +waitCatch :: ExpQ +waitCatch = rethrowWithLineNumber1 [| Async.waitCatch |] + +waitAny :: ExpQ +waitAny = rethrowWithLineNumber1 [| Async.waitAny |] + +waitAnyCatchCancel :: ExpQ +waitAnyCatchCancel = rethrowWithLineNumber1 [| Async.waitAnyCatchCancel |] + +#else + +{------------------------------------------------------------------------------- + MVar +-------------------------------------------------------------------------------} + +takeMVar :: ExpQ +takeMVar = [| C.takeMVar |] + +putMVar :: ExpQ +putMVar = [| C.putMVar |] + +readMVar :: ExpQ +readMVar = [| C.readMVar |] + +modifyMVar :: ExpQ +modifyMVar = [| C.modifyMVar |] + +modifyMVar_ :: ExpQ +modifyMVar_ = [| C.modifyMVar_ |] + +withMVar :: ExpQ +withMVar = [| C.withMVar |] + +swapMVar :: ExpQ +swapMVar = [| C.swapMVar |] + +{------------------------------------------------------------------------------- + StrictMVar +-------------------------------------------------------------------------------} + +takeStrictMVar :: ExpQ +takeStrictMVar = [| StrictMVar.takeMVar |] + +putStrictMVar :: ExpQ +putStrictMVar = [| StrictMVar.putMVar |] + +readStrictMVar :: ExpQ +readStrictMVar = [| StrictMVar.readMVar |] + +modifyStrictMVar :: ExpQ +modifyStrictMVar = [| StrictMVar.modifyMVar |] + +modifyStrictMVar_ :: ExpQ +modifyStrictMVar_ = [| StrictMVar.modifyMVar_ |] + +withStrictMVar :: ExpQ +withStrictMVar = [| StrictMVar.withMVar |] + +swapStrictMVar :: ExpQ +swapStrictMVar = [| StrictMVar.swapMVar |] + +{------------------------------------------------------------------------------- + Chan +-------------------------------------------------------------------------------} + +readChan :: ExpQ +readChan = [| C.readChan |] + +{------------------------------------------------------------------------------- + Async +-------------------------------------------------------------------------------} + +wait :: ExpQ +wait = [| Async.wait |] + +waitCatch :: ExpQ +waitCatch = [| Async.waitCatch |] + +waitAny :: ExpQ +waitAny = [| Async.waitAny |] + +waitAnyCatchCancel :: ExpQ +waitAnyCatchCancel = [| Async.waitAnyCatchCancel |] + +#endif diff --git a/IdeSession/Util/PrettyVal.hs b/IdeSession/Util/PrettyVal.hs new file mode 100644 --- /dev/null +++ b/IdeSession/Util/PrettyVal.hs @@ -0,0 +1,42 @@ +-- | (Orphan) PrettyVal instances for various standard datatypes +{-# OPTIONS_GHC -fno-warn-orphans #-} +module IdeSession.Util.PrettyVal ( + -- * Re-exports + PrettyVal(..) + ) where + +import Text.Show.Pretty +import Data.IntMap (IntMap) +import Data.Map (Map) +import Data.Trie (Trie) +import Data.ByteString (ByteString) +import Data.Text (Text) +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Trie as Trie +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Text as Text + +instance PrettyVal a => PrettyVal (Maybe a) where + prettyVal Nothing = Con "Nothing" [] + prettyVal (Just x) = Con "Just" [prettyVal x] + +-- TODO: This has encoding issues +instance PrettyVal ByteString where + prettyVal = prettyVal . BSC.unpack + +instance PrettyVal a => PrettyVal (IntMap a) where + prettyVal m = Con "fromList" [prettyVal . IntMap.toList $ m] + +instance (PrettyVal k, PrettyVal a) => PrettyVal (Map k a) where + prettyVal m = Con "fromList" [prettyVal . Map.toList $ m] + +instance PrettyVal a => PrettyVal (Trie a) where + prettyVal m = Con "fromList" [prettyVal . Trie.toList $ m] + +instance PrettyVal Bool where + prettyVal True = Con "True" [] + prettyVal False = Con "False" [] + +instance PrettyVal Text where + prettyVal = prettyVal . Text.unpack diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2015 FP Complete + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TestSuite/TestSuite.hs b/TestSuite/TestSuite.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite.hs @@ -0,0 +1,88 @@ +module Main where + +import Test.HUnit +import Test.Tasty + +import IdeSession +import TestSuite.State +import TestSuite.Tests.API +import TestSuite.Tests.Autocompletion +import TestSuite.Tests.BufferMode +import TestSuite.Tests.BuildDoc +import TestSuite.Tests.BuildExe +import TestSuite.Tests.BuildLicenses +import TestSuite.Tests.C +import TestSuite.Tests.CabalMacros +import TestSuite.Tests.Compilation +import TestSuite.Tests.Compliance +import TestSuite.Tests.Concurrency +import TestSuite.Tests.Crash +import TestSuite.Tests.Debugger +import TestSuite.Tests.FFI +import TestSuite.Tests.Integration +import TestSuite.Tests.InterruptRunExe +import TestSuite.Tests.InterruptRunStmt +import TestSuite.Tests.Issues +import TestSuite.Tests.Packages +import TestSuite.Tests.Performance +import TestSuite.Tests.SessionRestart +import TestSuite.Tests.SessionState +import TestSuite.Tests.SnippetEnvironment +import TestSuite.Tests.StdIO +import TestSuite.Tests.TH +import TestSuite.Tests.TypeInformation +import TestSuite.Tests.UpdateTargets + +-- | Sanity check: make sure we can communicate with the server at all +-- and that we get the expected version +testGetGhcVersion :: TestSuiteEnv -> Assertion +testGetGhcVersion env = withAvailableSession env $ \session -> do + version <- getGhcVersion session + assertEqual "" (testSuiteEnvGhcVersion env) version + +allTests :: String -> TestSuiteEnv -> TestTree +allTests name env = testGroup name [ + stdTest env "getGhcVersion" testGetGhcVersion + , testGroupIntegration env + , testGroupAPI env + , testGroupSessionState env + , testGroupCompilation env + , testGroupUpdateTargets env + , testGroupInterruptRunStmt env + , testGroupInterruptRunExe env + , testGroupStdIO env + , testGroupBufferMode env + , testGroupSnippetEnvironment env + , testGroupTypeInformation env + , testGroupAutocompletion env + , testGroupFFI env + , testGroupC env + , testGroupBuildExe env + , testGroupBuildDoc env + , testGroupBuildLicenses env + , testGroupCabalMacros env + , testGroupTH env + , testGroupIssues env + , testGroupPackages env + , testGroupSessionRestart env + , testGroupCrash env + , testGroupCompliance env + , testGroupDebugger env + , testGroupConcurrency env + , testGroupPerformance env + ] + +main :: IO () +main = + defaultMainWithIngredients ings $ testSuite $ \env -> + let TestSuiteConfig{..} = testSuiteEnvConfig env + env74 = env { testSuiteEnvGhcVersion = GHC_7_4 } + env78 = env { testSuiteEnvGhcVersion = GHC_7_8 } + env710 = env { testSuiteEnvGhcVersion = GHC_7_10 } + in testGroup "IDE backend tests" $ + (if testSuiteConfigTest74 then [allTests "GHC 7.4" env74] else []) + ++ (if testSuiteConfigTest78 then [allTests "GHC 7.8" env78] else []) + ++ (if testSuiteConfigTest710 then [allTests "GHC 7.10" env710] else []) + where + ings = includingOptions testSuiteCommandLineOptions + : defaultIngredients diff --git a/TestSuite/TestSuite/Assertions.hs b/TestSuite/TestSuite/Assertions.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Assertions.hs @@ -0,0 +1,522 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-} +-- | Convenience assertions +module TestSuite.Assertions ( + -- * General assertions + collectErrors + , assertSameSet + , assertRaises + -- * Assertions about session state + , assertLoadedModules + -- * Assertions about source code errors + , assertNoErrors + , assertOneError + , assertSomeErrors + , assertMoreErrors + , assertSourceErrors + , assertSourceErrors' + , assertErrorOneOf + , show3errors + -- * Assertions about type information + , assertIdInfo + , assertIdInfo' + , assertExpTypes + , ignoreVersions + , allVersions + , from78 + , from710 + , assertUseSites + , assertAlphaEquiv + -- * Known problems + , fixme + -- * Auxiliary + , isAsyncException + , mkSpan + ) where + +import Prelude hiding (mod, span) +import Control.Monad +import Data.Char +import Data.Either +import Data.Function (on) +import Data.List hiding (span) +import Test.HUnit +import Test.HUnit.Lang +import Text.Regex (mkRegex, subRegex) +import qualified Control.Exception as Ex +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.ByteString.UTF8 as S +import qualified Data.Text as T + +import IdeSession +import TestTools + +{------------------------------------------------------------------------------- + General assertions +-------------------------------------------------------------------------------} + +-- | Don't fail on the first assertion, but run all and collect all errors +collectErrors :: [Assertion] -> Assertion +collectErrors as = do + es <- lefts `liftM` (sequence $ map Ex.try as) + if null es + then return () + else Ex.throwIO (concatFailures es) + where + concatFailures :: [HUnitFailure] -> HUnitFailure + concatFailures = go [] + where + go acc [] = HUnitFailure (unlines . reverse $ acc) + go acc (HUnitFailure e : es) = go (e : acc) es + +-- | Compare two sets. The expected set is the _second_ set +-- (inconsistent with the rest of the assertions but more convenient) +assertSameSet :: (Ord a, Show a) => String -> [a] -> [a] -> Assertion +assertSameSet header = aux `on` sort + where + aux :: (Ord a, Show a) => [a] -> [a] -> Assertion + aux actual expected = + case diff expected actual of + ([], []) -> + return () + (missing, unexpected) -> + assertFailure $ header + ++ "\nMissing: " ++ show missing + ++ "\nUnexpected: " ++ show unexpected + +{------------------------------------------------------------------------------- + Assertions about session state +-------------------------------------------------------------------------------} + +assertLoadedModules :: IdeSession -> String -> [String] -> Assertion +assertLoadedModules session header goodMods = do + loadedMods <- getLoadedModules session + assertSameSet header (map T.pack goodMods) loadedMods + +{------------------------------------------------------------------------------- + Assertions about source code errors +-------------------------------------------------------------------------------} + +assertNoErrors :: IdeSession -> Assertion +assertNoErrors session = do + errs <- getSourceErrors session + assertBool ("Unexpected errors: " ++ show3errors errs) $ null errs + +assertOneError :: IdeSession -> Assertion +assertOneError session = do + assertSomeErrors session + msgs <- getSourceErrors session + assertBool ("Too many type errors: " ++ show3errors msgs) + $ length msgs <= 1 + +assertSomeErrors :: IdeSession -> Assertion +assertSomeErrors session = do + msgs <- getSourceErrors session + assertBool "An error was expected, but not found" $ length msgs >= 1 + +assertMoreErrors :: IdeSession -> Assertion +assertMoreErrors session = do + msgs <- getSourceErrors session + assertBool ("Too few type errors: " ++ show3errors msgs) + $ length msgs >= 2 + +show3errors :: [SourceError] -> String +show3errors errs = + let shown = intercalate "\n" (map show $ take 3 $ errs) + more | length errs > 3 = "\n... and more ..." + | otherwise = "" + in shown ++ more + +-- @assertSourceErrors session [[a,b,c],[d,e,f],..] checks that there are +-- exactly as many errors as elements in the outer list, and each of those +-- errors must match one of the errors inside the inner lists +assertSourceErrors :: IdeSession -> [[(Maybe FilePath, String)]] -> Assertion +assertSourceErrors session expected = do + errs <- getSourceErrors session + if length errs /= length expected + then assertFailure $ "Unexpected source errors: " ++ show3errors errs + else forM_ (zip expected errs) $ \(potentialExpected, actualErr) -> + assertErrorOneOf actualErr potentialExpected + +assertSourceErrors' :: IdeSession -> [String] -> Assertion +assertSourceErrors' session = assertSourceErrors session . map + (\err -> [(Nothing, err)]) + +assertErrorOneOf :: SourceError -> [(Maybe FilePath, String)] -> Assertion +assertErrorOneOf (SourceError _ loc actual) potentialExpected = + case foldr1 mplus (map matches potentialExpected) of + Left err -> assertFailure err + Right () -> return () + where + matches (mFP, expErr) = do + matchesFilePath mFP + matchesError expErr + + matchesFilePath Nothing = Right () + matchesFilePath (Just expectedPath) = + case loc of + ProperSpan (SourceSpan actualPath _ _ _ _) -> + if expectedPath `isSuffixOf` actualPath + then Right () + else Left "Wrong file" + _ -> + Left "Expected location" + + matchesError expectedErr = + if ignoreQuotes expectedErr `isInfixOf` ignoreQuotes (T.unpack actual) + then Right () + else Left $ "Unexpected error: " ++ show (T.unpack actual) ++ ".\nExpected: " ++ show expectedErr + +{------------------------------------------------------------------------------- + Assertions about type information +-------------------------------------------------------------------------------} + +assertIdInfo :: IdeSession + -> String -- ^ Module + -> (Int, Int, Int, Int) -- ^ Location + -> String -- ^ Name + -> IdNameSpace -- ^ Namespace + -> String -- ^ Type + -> String -- ^ Defining module + -> String -- ^ Defining span + -> String -- ^ Home module + -> String -- ^ Scope + -> Assertion +assertIdInfo session + mod + (frLine, frCol, toLine, toCol) + expectedName + expectedNameSpace + expectedType + expectedDefModule + expectedDefSpan + expectedHome + expectedScope = + assertIdInfo' session + mod + (frLine, frCol, toLine, toCol) + (frLine, frCol, toLine, toCol) + expectedName + expectedNameSpace + (case expectedType of "" -> [] + _ -> allVersions expectedType) + (allVersions expectedDefModule) + (allVersions expectedDefSpan) + (allVersions expectedHome) + (allVersions expectedScope) + +-- | If no answer is specified for a given version, it will not be verified +type PerVersion a = [(GhcVersion, a)] + +allVersions :: a -> PerVersion a +allVersions x = [(GHC_7_4, x), (GHC_7_8, x), (GHC_7_10, x)] + +-- | One case for 7.4, and one for 7.8 and up +from78 :: a -> a -> PerVersion a +from78 x y = [(GHC_7_4, x), (GHC_7_8, y), (GHC_7_10, y)] + +-- | One case for 7.4 and 7.8, and one for 7.10 and up +from710 :: a -> a -> PerVersion a +from710 x y = [(GHC_7_4, x), (GHC_7_8, x), (GHC_7_10, y)] + +assertIdInfo' :: IdeSession + -> String -- ^ Module + -> (Int, Int, Int, Int) -- ^ Location + -> (Int, Int, Int, Int) -- ^ Precise location + -> String -- ^ Name + -> IdNameSpace -- ^ Namespace + -> PerVersion String -- ^ Type + -> PerVersion String -- ^ Defining module + -> PerVersion String -- ^ Defining span + -> PerVersion String -- ^ Home module + -> PerVersion String -- ^ Scope + -> Assertion +assertIdInfo' session + mod + givenLocation + expectedLocation + expectedName + expectedNameSpace + expectedTypes + expectedDefModules + expectedDefSpans + expectedHomes + expectedScopes = do + idInfo <- getSpanInfo session + version <- getGhcVersion session + case idInfo (T.pack mod) givenSpan of + (actualSpan, SpanId actualInfo) : _ -> compareIdInfo version actualSpan actualInfo + (actualSpan, SpanQQ actualInfo) : _ -> compareIdInfo version actualSpan actualInfo + _ -> assertFailure $ "No id info found for " ++ show expectedName + ++ " at " ++ show mod ++ ":" ++ show givenLocation + where + givenSpan, expectedSpan :: SourceSpan + (_givenMod, givenSpan) = mkSpan mod givenLocation + (_expectedMod, expectedSpan) = mkSpan mod expectedLocation + + compareIdInfo :: GhcVersion -> SourceSpan -> IdInfo -> Assertion + compareIdInfo version actualSpan IdInfo{idProp = IdProp{..}, idScope} = + collectErrors [ + assertEqual "name" expectedName (T.unpack idName) + , assertEqual "location" expectedSpan actualSpan + , assertEqual "namespace" expectedNameSpace idSpace + + , case lookup version expectedDefSpans of + Nothing -> + return () + Just expectedDefSpan -> + assertEqual "def span" expectedDefSpan (show idDefSpan) + + , case lookup version expectedDefModules of + Nothing -> + return () + Just expectedDefModule -> + assertEqual "def module" (ignoreVersions expectedDefModule) + (ignoreVersions (show idDefinedIn)) + + , case lookup version expectedScopes of + Nothing -> return () + Just expectedScope -> assertEqual "scope" (ignoreVersions expectedScope) + (ignoreVersions (show idScope)) + + , case (lookup version expectedTypes, idType) of + (Just expectedType, Just actualType) -> + assertAlphaEquiv "type" expectedType (T.unpack actualType) + (Just expectedType, Nothing) -> + assertFailure $ "expected type " ++ expectedType ++ ", but got none" + (Nothing, _) -> + -- Not checking + return () + + , case (lookup version expectedHomes, idHomeModule) of + (Just expectedHome, Nothing) -> + assertEqual "home" expectedHome "" + (Just expectedHome, Just actualHome) -> + assertEqual "home" (ignoreVersions expectedHome) + (ignoreVersions (show actualHome)) + (Nothing, _) -> + -- Not checking + return () + ] + +assertExpTypes :: (ModuleName -> SourceSpan -> [(SourceSpan, T.Text)]) + -> String + -> (Int, Int, Int, Int) + -> [(Int, Int, Int, Int, String)] + -> Assertion +assertExpTypes expTypes mod loc expected = + assertAlphaEquiv "" expected actual + where + actual = flip map (uncurry expTypes $ mkSpan mod loc) $ \(span, typ) -> + ( spanFromLine span + , spanFromColumn span + , spanToLine span + , spanToColumn span + , T.unpack typ + ) + +assertUseSites :: (ModuleName -> SourceSpan -> [SourceSpan]) + -> String + -> (Int, Int, Int, Int) + -> String + -> [String] + -> Assertion +assertUseSites useSites mod loc symbol expected = + assertEqual ("Use sites of `" ++ symbol ++ "` in " ++ show mod) expected actual + where + actual = map show (uncurry useSites $ mkSpan mod loc) + +{------------------------------------------------------------------------------ + Replace (type variables) with numbered type variables + + i.e., change "b -> [c]" to "a1 -> [a2]" + + useful for comparing types for alpha-equivalence +------------------------------------------------------------------------------} + +assertAlphaEquiv :: (IgnoreVarNames a, Eq a, Show a) => String -> a -> a -> Assertion +assertAlphaEquiv label a b = + if ignoreVarNames a == ignoreVarNames b + then return () + else assertFailure $ label ++ "\n" + ++ "expected: " ++ show a + ++ " but got: " ++ show b + +class IgnoreVarNames a where + ignoreVarNames :: a -> a + +instance IgnoreVarNames a => IgnoreVarNames [a] where + ignoreVarNames = map ignoreVarNames + +instance IgnoreVarNames a => IgnoreVarNames (Int, Int, Int, Int, a) where + ignoreVarNames (a, b, c, d, e) = (a, b, c, d, ignoreVarNames e) + +instance IgnoreVarNames String where + ignoreVarNames = unwords . go [] [] . tokenize + where + go :: [String] -> [String] -> [String] -> [String] + go _vars acc [] = reverse acc + go vars acc (x:xs) + | isVar x = case elemIndex x vars of + Just n -> go vars (var n : acc) xs + Nothing -> go (vars ++ [x]) acc (x : xs) + | otherwise = go vars (x : acc) xs + + isVar :: String -> Bool + isVar [] = False + isVar (x:_) = isLower x + + var :: Int -> String + var n = "a" ++ show n + +-- | Repeatedly call lex +tokenize :: String -> [String] +tokenize [] = [[]] +tokenize xs = case lex xs of + [(token, xs')] -> token : tokenize xs' + _ -> error "tokenize failed" + +{------------------------------------------------------------------------------ + Abstract away versions +------------------------------------------------------------------------------} + +class IgnoreVersions a where + ignoreVersions :: a -> a + +instance IgnoreVersions String where + ignoreVersions s = subRegex (mkRegex versionRegexp) s "X.Y.Z" + where + versionRegexp :: String + versionRegexp = "[0-9]+(\\.[0-9]+)+" + +instance IgnoreVersions a => IgnoreVersions [a] where + ignoreVersions = map ignoreVersions + +instance IgnoreVersions a => IgnoreVersions (Maybe a) where + ignoreVersions = fmap ignoreVersions + +instance IgnoreVersions S.ByteString where + ignoreVersions = S.fromString . ignoreVersions . S.toString + +instance IgnoreVersions L.ByteString where + ignoreVersions = L.fromString . ignoreVersions . L.toString + +instance IgnoreVersions T.Text where + ignoreVersions = T.pack . ignoreVersions . T.unpack + +instance IgnoreVersions Import where + ignoreVersions Import{..} = Import { + importModule = ignoreVersions importModule + , importPackage = importPackage + , importQualified = importQualified + , importImplicit = importImplicit + , importAs = importAs + , importEntities = importEntities + } + +instance IgnoreVersions ModuleId where + ignoreVersions ModuleId{..} = ModuleId { + moduleName = moduleName + , modulePackage = ignoreVersions modulePackage + } + +-- From 7.10 and up the package key is a hash that includes the package version, +-- which is definitely not something we want to compare when we ignore versions. +-- So here we just replace the package key with the package name. +instance IgnoreVersions PackageId where + ignoreVersions PackageId{..} = PackageId { + packageName = packageName + , packageVersion = ignoreVersions packageVersion + , packageKey = packageName + } + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Compare two lists, both assumed sorted +-- +-- @diff expected actual@ returns two lists: +-- +-- * The first contains the elements in the first but not the second list +-- * The second contains the elements in the second but not the first list +-- +-- If the first list is the "expected" list and the second list is the "actual" +-- list then the first list of the result are the "missing" elements and the +-- second list of the result are the "unexpected" elements. +-- or an empty lists if the input lists are identical +diff :: Ord a => [a] -> [a] -> ([a], [a]) +diff [] [] = ([], []) +diff xs [] = (xs, []) +diff [] ys = ([], ys) +diff (x:xs) (y:ys) + | x < y = let (missing, unexpected) = diff xs (y:ys) + in (x:missing, unexpected) + | x > y = let (missing, unexpected) = diff (x:xs) ys + in (missing, y:unexpected) + | otherwise = diff xs ys + +-- | Replace everything that looks like a quote by a standard single quote. +ignoreQuotes :: String -> String +ignoreQuotes s = subRegex (mkRegex quoteRegexp) s "'" + where + quoteRegexp :: String + quoteRegexp = "[‘‛’`\"]" + +isAsyncException :: RunResult -> Bool +isAsyncException (RunProgException ex) = + (ex == "AsyncException: user interrupt") + || (ex == "SomeAsyncException: user interrupt") +isAsyncException _ = False + +mkSpan :: String -> (Int, Int, Int, Int) -> (ModuleName, SourceSpan) +mkSpan mod (frLine, frCol, toLine, toCol) = (T.pack mod, span) + where + span = SourceSpan { spanFilePath = mod ++ ".hs" + , spanFromLine = frLine + , spanFromColumn = frCol + , spanToLine = toLine + , spanToColumn = toCol + } + +{------------------------------------------------------------------------------ + Known problems +------------------------------------------------------------------------------} + +-- | Which ghc versions are affected by these problems? +-- ([] if the bug is unrelated to the GHC version) +knownProblems :: [(String, [GhcVersion])] +knownProblems = [ + -- https://github.com/fpco/ide-backend/issues/32 + -- TODO: In 7.8 the error message does not include a filepath at all, + -- so the error does not crop up. I don't know if this is true for _all_ + -- errors or just for this particular one (I tried a few but didn't see + -- filepaths in any of them). + ("#32", [GHC_7_4]) + -- https://github.com/fpco/ide-backend/issues/254 + , ("#254", [GHC_7_10]) + ] + +fixme :: IdeSession -> String -> IO () -> IO String +fixme session bug io = do + version <- getGhcVersion session + let mAllAffected = lookup bug knownProblems + isAffected = case mAllAffected of + Nothing -> False + Just allAffected -> null allAffected + || version `elem` allAffected + + mErr <- Ex.catch (io >> return Nothing) $ \e -> + case Ex.fromException e of + Just (HUnitFailure err) -> return (Just err) + Nothing -> return (Just $ show e) + + case mErr of + Just err -> + if isAffected + then return "Expected failure" + else Ex.throwIO . userError $ "Unexpected failure: " ++ err + Nothing -> + if isAffected + then Ex.throwIO . userError $ "Unexpected success" + ++ " (expected " ++ bug ++ ")" + else return "" diff --git a/TestSuite/TestSuite/Session.hs b/TestSuite/TestSuite/Session.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Session.hs @@ -0,0 +1,120 @@ +-- | Working with IDE sessions +module TestSuite.Session ( + updateSessionD + , updateSessionP + , loadModule + , loadModulesFrom + , loadModulesFrom' + , getModules + , getModulesFrom + ) where + +import Prelude hiding (mod) +import Control.Monad +import Data.IORef +import Data.List (isPrefixOf, isInfixOf) +import Data.Monoid +import System.FilePath +import System.FilePath.Find (always, extension, find) +import Test.HUnit +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.Text as T + +import IdeSession + +updateSessionD :: IdeSession -> IdeSessionUpdate -> Int -> IO () +updateSessionD session update numProgressUpdates = do + progressRef <- newIORef [] + + -- We just collect the progress messages first, and verify them afterwards + updateSession session update $ \p -> do + progressUpdates <- readIORef progressRef + writeIORef progressRef $ progressUpdates ++ [p] + + -- These progress messages are often something like + -- + -- [18 of 27] Compiling IdeSession.Types.Private ( IdeSession/Types/Private.hs, dist/build/IdeSession/Types/Private.o ) + -- [19 of 27] Compiling IdeSession.GHC.API ( IdeSession/GHC/API.hs, dist/build/IdeSession/GHC/API.o ) + -- [20 of 27] Compiling IdeSession.GHC.Client ( IdeSession/GHC/Client.hs, dist/build/IdeSession/GHC/Client.p_o ) + -- [21 of 27] Compiling IdeSession.Types.Translation ( IdeSession/Types/Translation.hs, dist/build/IdeSession/Types/Translation.p_o ) + -- [23 of 27] Compiling IdeSession.State ( IdeSession/State.hs, dist/build/IdeSession/State.p_o ) + -- + -- So these numbers don't need to start at 1, may be discontiguous, out of + -- order, and may not end with [X of X]. The only thing we can check here is + -- that we get at most the number of progress messages we expect. + progressUpdates <- readIORef progressRef + assertBool ("We expected " ++ show numProgressUpdates ++ " progress messages, but got " ++ show progressUpdates) + (length progressUpdates <= numProgressUpdates) + +updateSessionP :: IdeSession -> IdeSessionUpdate -> [(Int, Int, String)] -> IO () +updateSessionP session update expectedProgressUpdates = do + progressRef <- newIORef [] + + -- We just collect the progress messages first, and verify them afterwards + updateSession session update $ \p -> do + progressUpdates <- readIORef progressRef + writeIORef progressRef $ progressUpdates ++ [p] + + progressUpdates <- readIORef progressRef + assertBool ("We expected " ++ show expectedProgressUpdates ++ ", but got " ++ show progressUpdates) + (length progressUpdates <= length expectedProgressUpdates) + + forM_ (zip progressUpdates expectedProgressUpdates) $ \(actual, expected@(step, numSteps, msg)) -> + assertBool ("Unexpected progress update " ++ show actual ++ "; expected " ++ show expected) + (progressStep actual == step && + progressNumSteps actual == numSteps && + case progressOrigMsg actual of + Just actualMsg -> msg `isInfixOf` T.unpack actualMsg + Nothing -> False) + +loadModule :: FilePath -> String -> IdeSessionUpdate +loadModule file contents = + let mod = "module " ++ mname file ++ " where\n" ++ contents + in updateSourceFile file (L.fromString mod) + where + -- This is a hack: construct a module name from a filename + mname :: FilePath -> String + mname path = case "TestSuite/inputs/" `substr` path of + Just rest -> dotToSlash . dropExtension . dropFirstPathComponent $ rest + Nothing -> takeBaseName path + + dropFirstPathComponent :: FilePath -> FilePath + dropFirstPathComponent = tail . dropWhile (/= '/') + + dotToSlash :: String -> String + dotToSlash = map $ \c -> if c == '/' then '.' else c + + -- | Specification: + -- + -- > bs `substr` (as ++ bs ++ cs) == Just cs + -- > bs `substr` _ == Nothing + substr :: Eq a => [a] -> [a] -> Maybe [a] + substr needle haystack + | needle `isPrefixOf` haystack = Just $ drop (length needle) haystack + | otherwise = case haystack of + [] -> Nothing + (_ : haystack') -> substr needle haystack' + +loadModulesFrom :: IdeSession -> FilePath -> IO () +loadModulesFrom session originalSourcesDir = + loadModulesFrom' session originalSourcesDir $ TargetsExclude [] + +loadModulesFrom' :: IdeSession -> FilePath -> Targets -> IO () +loadModulesFrom' session originalSourcesDir targets = do + (originalUpdate, lm) <- getModulesFrom originalSourcesDir + updateSessionD session (originalUpdate <> updateTargets targets) (length lm) + +getModules :: IdeSession -> IO (IdeSessionUpdate, [FilePath]) +getModules session = getModulesFrom =<< getSourcesDir session + +-- | Update the session with all modules of the given directory. +getModulesFrom :: FilePath -> IO (IdeSessionUpdate, [FilePath]) +getModulesFrom originalSourcesDir = do + -- Send the source files from 'originalSourcesDir' to 'configSourcesDir' + -- using the IdeSession's update mechanism. + originalFiles <- find always + ((`elem` sourceExtensions) `liftM` extension) + originalSourcesDir + let originalUpdate = updateCodeGeneration False + <> (mconcat $ map updateSourceFileFromFile originalFiles) + return (originalUpdate, originalFiles) diff --git a/TestSuite/TestSuite/State.hs b/TestSuite/TestSuite/State.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/State.hs @@ -0,0 +1,876 @@ +-- | Test suite global state +module TestSuite.State ( + -- * Top-level test groups + TestSuiteState -- Opaque + , TestSuiteConfig(..) + , TestSuiteEnv(..) + , TestSuiteServerConfig(..) + , TestSuiteSessionSetup(..) + , testSuite + , testSuiteCommandLineOptions + -- * Operations on the test suite state + , withAvailableSession + , withAvailableSession' + , startNewSession + , defaultSessionSetup + , defaultServerConfig + , withGhcOpts + , withIncludes + , withModInfo + , withDBStack + , dontReuse + , skipTest + , ifTestingExe + , ifTestingIntegration + -- * Constructing tests + , stdTest + , withOK + , docTests + , exeTests + , integrationTests + -- * Paths + , testInputPathCabal + -- * Test suite global state + , withCurrentDirectory + , findExe + , withInstalledPackage + , packageCheck + ) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.DeepSeq (rnf) +import Control.Exception +import Control.Monad +import Data.Maybe +import Data.Monoid +import Data.Proxy +import Data.Typeable +import System.Directory +import System.Environment +import System.FilePath +import System.IO (hGetContents, hClose) +import System.IO.Unsafe (unsafePerformIO) +import System.Process +import Test.HUnit (Assertion) +import Test.HUnit.Lang (HUnitFailure(..)) +import Test.Tasty +import Test.Tasty.Options +import Test.Tasty.Providers +import qualified Data.Map as Map +import qualified Distribution.Simple.Program.Find as OurCabal +import qualified Data.ByteString.Lazy as L + +import IdeSession + +{------------------------------------------------------------------------------- + Test suite top-level +-------------------------------------------------------------------------------} + +data TestSuiteConfig = TestSuiteConfig { + -- | Keep session temp files + testSuiteConfigKeepTempFiles :: Bool + + -- | Start a new session for each test + , testSuiteConfigNoSessionReuse :: Bool + + -- | No haddock documentation installed on the test system + , testSuiteConfigNoHaddocks :: Bool + + -- | Skip buildExe tests + , testSuiteConfigNoExe :: Bool + + -- | Skip integration tests + , testSuiteConfigNoIntegration :: Bool + + -- | Package DB stack for GHC 7.4 + , testSuiteConfigPackageDb74 :: Maybe String + + -- | Package DB stack for GHC 7.8 + , testSuiteConfigPackageDb78 :: Maybe String + + -- | Package DB stack for GHC 7.10 + , testSuiteConfigPackageDb710 :: Maybe String + + -- | Extra paths for GHC 7.4 + , testSuiteConfigExtraPaths74 :: String + + -- | Extra paths for GHC 7.8 + , testSuiteConfigExtraPaths78 :: String + + -- | Extra paths for GHC 7.10 + , testSuiteConfigExtraPaths710 :: String + + -- | Should we test against GHC 7.4? + , testSuiteConfigTest74 :: Bool + + -- | Should we test against GHC 7.8? + , testSuiteConfigTest78 :: Bool + + -- | Should we test against GHC 7.10? + , testSuiteConfigTest710 :: Bool + } + deriving (Eq, Show) + +data TestSuiteState = TestSuiteState { + -- | Previously created sessions + -- + -- These sessions are free (no concurrent test is currently using them) + testSuiteStateAvailableSessions :: MVar [(TestSuiteServerConfig, IdeSession)] + } + +data TestSuiteEnv = TestSuiteEnv { + testSuiteEnvConfig :: TestSuiteConfig + , testSuiteEnvState :: IO TestSuiteState + , testSuiteEnvGhcVersion :: GhcVersion + } + +testSuite :: (TestSuiteEnv -> TestTree) -> TestTree +testSuite tests = + parseOptions $ \testSuiteEnvConfig -> + withResource initTestSuiteState cleanupTestSuiteState $ \testSuiteEnvState -> + tests TestSuiteEnv { + testSuiteEnvGhcVersion = error "testSuiteEnvGhcVersion not yet set" + , .. + } + +{------------------------------------------------------------------------------- + Stateful operations (on the test suite state) +-------------------------------------------------------------------------------} + +-- | Run the given action with an available session (new or previously created) +withAvailableSession :: TestSuiteEnv -> (IdeSession -> IO a) -> IO a +withAvailableSession env = withAvailableSession' env id + +data TestSuiteSessionSetup = TestSuiteSessionSetup { + testSuiteSessionServer :: TestSuiteServerConfig + , testSuiteSessionGhcOpts :: [String] + , testSuiteSessionReuse :: Bool + } + +defaultSessionSetup :: TestSuiteEnv -> TestSuiteSessionSetup +defaultSessionSetup env = TestSuiteSessionSetup { + testSuiteSessionServer = defaultServerConfig env + , testSuiteSessionGhcOpts = [] + , testSuiteSessionReuse = True + } + +withGhcOpts :: [String] -> TestSuiteSessionSetup -> TestSuiteSessionSetup +withGhcOpts opts setup = setup { + testSuiteSessionGhcOpts = opts + } + +withIncludes :: [FilePath] -> TestSuiteSessionSetup -> TestSuiteSessionSetup +withIncludes incls setup = setup { + testSuiteSessionServer = (testSuiteSessionServer setup) { + testSuiteServerRelativeIncludes = Just (incls ++ sessionInitRelativeIncludes defaultSessionInitParams) + } + } + +withModInfo :: Bool -> TestSuiteSessionSetup -> TestSuiteSessionSetup +withModInfo modInfo setup = setup { + testSuiteSessionServer = (testSuiteSessionServer setup) { + testSuiteServerGenerateModInfo = Just modInfo + } + } + +withDBStack :: PackageDBStack -> TestSuiteSessionSetup -> TestSuiteSessionSetup +withDBStack dbStack setup = setup { + testSuiteSessionServer = (testSuiteSessionServer setup) { + testSuiteServerPackageDBStack = Just dbStack + } + } + +dontReuse :: TestSuiteSessionSetup -> TestSuiteSessionSetup +dontReuse setup = setup { + testSuiteSessionReuse = False + } + +-- | More general version of 'withAvailableSession' +withAvailableSession' :: TestSuiteEnv -> (TestSuiteSessionSetup -> TestSuiteSessionSetup) -> (IdeSession -> IO a) -> IO a +withAvailableSession' env@TestSuiteEnv{..} sessionSetup act = do + TestSuiteState{..} <- testSuiteEnvState + + -- Find an available session, if one exists + msession <- extractMVar ((== testSuiteSessionServer) . fst) + testSuiteStateAvailableSessions + + -- If there is none, start a new one + session <- case msession of + Just session -> return (snd session) + Nothing -> startNewSession testSuiteSessionServer + + -- Setup session parameters + let setup = updateGhcOpts testSuiteSessionGhcOpts + <> updateRelativeIncludes (sessionInitRelativeIncludes (deriveSessionInitParams testSuiteSessionServer)) + updateSession session setup (\_ -> return ()) + + -- Run the test + mresult <- try $ act session + + -- Make the session available for further tests, or shut it down if the + -- @--no-session-reuse@ command line option was used + if testSuiteConfigNoSessionReuse testSuiteEnvConfig || not testSuiteSessionReuse + then + shutdownSession session + else do + resetSession session + + -- resetSession does some sanity checks to make sure that the session + -- reset worked okay. If these sanity checks fail, it will throw an + -- exception, in which case we will _not_ make that session available + -- for further use. This will leak the session, but that's okay: it's a + -- bug when this happens. + consMVar (testSuiteSessionServer, session) testSuiteStateAvailableSessions + + -- Return test result + case mresult of + Left ex -> throwIO (ex :: SomeException) + Right result -> return result + where + TestSuiteSessionSetup{..} = sessionSetup (defaultSessionSetup env) + +-- | Reset a session so that it can be reused in subsequent tests +-- +-- This does not change any parameters that we have to set anyway +-- (that is, anything set in `setup` in `withAvailableSession'`). +-- +-- An alternative would be to set these parameters here to their ide-backend +-- defaults; in that case, we could actually add an 'updateReset' to the +-- ide-backend API. +resetSession :: IdeSession -> IO () +resetSession session = do + updateSession session reset (\_ -> return ()) + + -- Sanity check: after updateDeleteManagedFiles the managed files should + -- actually be gone! (#238) + -- Ignoring object files due to #249. + checkIsEmpty ignoredExtensions =<< getSourcesDir session + checkIsEmpty ignoredExtensions =<< getDataDir session + where + reset = updateDeleteManagedFiles + <> updateCodeGeneration False + <> updateEnv [] + <> updateTargets (sessionInitTargets defaultSessionInitParams) + <> updateRtsOpts (sessionInitRtsOpts defaultSessionInitParams) + + ignoredExtensions = [".o", ".dyn_o"] + +defaultServerConfig :: TestSuiteEnv -> TestSuiteServerConfig +defaultServerConfig TestSuiteEnv{..} = TestSuiteServerConfig { + testSuiteServerConfig = testSuiteEnvConfig + , testSuiteServerGhcVersion = testSuiteEnvGhcVersion + , testSuiteServerRelativeIncludes = Nothing + , testSuiteServerGenerateModInfo = Nothing + , testSuiteServerPackageDBStack = Nothing + , testSuiteServerCabalMacros = Nothing + } + +-- | Skip (the remainder of) this test +skipTest :: String -> IO () +skipTest = throwIO . SkipTest + +-- | Skip this (part of) the test if --no-exe is passed +ifTestingExe :: TestSuiteEnv -> Assertion -> Assertion +ifTestingExe TestSuiteEnv{..} act = + unless testSuiteConfigNoExe act + where + TestSuiteConfig{..} = testSuiteEnvConfig + +-- | Skip this if --no-integration +ifTestingIntegration :: TestSuiteEnv -> Assertion -> Assertion +ifTestingIntegration TestSuiteEnv{..} act = do + unless testSuiteConfigNoIntegration act + where + TestSuiteConfig{..} = testSuiteEnvConfig + +{------------------------------------------------------------------------------- + Constructing tests + + This is similar to what tasty-hunit provides, but we provide better support + for skipping tests +-------------------------------------------------------------------------------} + +data TestCase = + StdTest TestName Assertion + -- Tests that report more than just "OK" + | WithOK TestName (IO String) + deriving Typeable + +runTestCase :: TestCase -> IO Result +runTestCase (StdTest nm t) = registerTest nm t >> return (testPassed "") +runTestCase (WithOK nm t) = registerTest nm t >>= return . testPassed + +instance IsTest TestCase where + -- TODO: Measure time and use for testPassed in normal case + run _ test _ = runTestCase test `catches` [ + Handler $ \(HUnitFailure msg) -> return (testFailed msg) + , Handler $ \(SkipTest msg) -> return (testPassed ("Skipped (" ++ msg ++ ")")) + ] + + -- TODO: Should this reflect testCaseEnabled? + testOptions = return [] + +newtype SkipTest = SkipTest String + deriving (Show, Typeable) + +instance Exception SkipTest + +-- | Construct a standard test case +stdTest :: TestSuiteEnv -> TestName -> (TestSuiteEnv -> Assertion) -> TestTree +stdTest st name = singleTest name . StdTest name . ($ st) + +-- | Construct a test case that reports OK with a non-standard string +withOK :: TestSuiteEnv -> TestName -> (TestSuiteEnv -> IO String) -> TestTree +withOK st name = singleTest name . WithOK name . ($ st) + +-- | Lists of tests that should be run only if Haddocks are installed +docTests :: TestSuiteEnv -> [TestTree] -> [TestTree] +docTests TestSuiteEnv{..} ts + | testSuiteConfigNoHaddocks = [] + | otherwise = ts + where + TestSuiteConfig{..} = testSuiteEnvConfig + +-- | Lists of tests that should be run only of --no-exe is not passed +exeTests :: TestSuiteEnv -> [TestTree] -> [TestTree] +exeTests TestSuiteEnv{..} ts + | testSuiteConfigNoExe = [] + | otherwise = ts + where + TestSuiteConfig{..} = testSuiteEnvConfig + +-- | Lists of tests that should be run only of --no-integration is not passed +integrationTests :: TestSuiteEnv -> [TestTree] -> [TestTree] +integrationTests TestSuiteEnv{..} ts + | testSuiteConfigNoIntegration = [] + | otherwise = ts + where + TestSuiteConfig{..} = testSuiteEnvConfig + +{------------------------------------------------------------------------------- + Internal +-------------------------------------------------------------------------------} + +-- | When we request a session, we request one given a 'TestSuiteServerConfig'. +-- This should therefore have two properties: +-- +-- 1. They should be testable for equality +-- 2. The server configuration should be determined fully by a +-- 'TestSuiteServerConfig'. +data TestSuiteServerConfig = TestSuiteServerConfig { + testSuiteServerConfig :: TestSuiteConfig + , testSuiteServerGhcVersion :: GhcVersion + , testSuiteServerRelativeIncludes :: Maybe [FilePath] + , testSuiteServerGenerateModInfo :: Maybe Bool + , testSuiteServerPackageDBStack :: Maybe PackageDBStack + , testSuiteServerCabalMacros :: Maybe L.ByteString + } + deriving (Eq, Show) + +startNewSession :: TestSuiteServerConfig -> IO IdeSession +startNewSession cfg = initSession (deriveSessionInitParams cfg) + (deriveSessionConfig cfg) + +deriveSessionInitParams :: TestSuiteServerConfig -> SessionInitParams +deriveSessionInitParams TestSuiteServerConfig{..} = defaultSessionInitParams { + sessionInitCabalMacros = + testSuiteServerCabalMacros + `mplus` + sessionInitCabalMacros defaultSessionInitParams + , sessionInitRelativeIncludes = + fromMaybe (sessionInitRelativeIncludes defaultSessionInitParams) $ + testSuiteServerRelativeIncludes + } + where + TestSuiteConfig{..} = testSuiteServerConfig + +deriveSessionConfig :: TestSuiteServerConfig -> SessionConfig +deriveSessionConfig TestSuiteServerConfig{..} = defaultSessionConfig { + configDeleteTempFiles = + not testSuiteConfigKeepTempFiles + , configPackageDBStack = + fromMaybe (configPackageDBStack defaultSessionConfig) $ + ( + testSuiteServerPackageDBStack + `mplus` + do packageDb <- case testSuiteServerGhcVersion of + GHC_7_4 -> testSuiteConfigPackageDb74 + GHC_7_8 -> testSuiteConfigPackageDb78 + GHC_7_10 -> testSuiteConfigPackageDb710 + return [GlobalPackageDB, SpecificPackageDB packageDb] + ) + , configExtraPathDirs = + splitSearchPath $ case testSuiteServerGhcVersion of + GHC_7_4 -> testSuiteConfigExtraPaths74 + GHC_7_8 -> testSuiteConfigExtraPaths78 + GHC_7_10 -> testSuiteConfigExtraPaths710 + , configGenerateModInfo = + fromMaybe (configGenerateModInfo defaultSessionConfig) $ + testSuiteServerGenerateModInfo + } + where + TestSuiteConfig{..} = testSuiteServerConfig + +initTestSuiteState :: IO TestSuiteState +initTestSuiteState = do + testSuiteStateAvailableSessions <- newMVar [] + return TestSuiteState{..} + +cleanupTestSuiteState :: TestSuiteState -> IO () +cleanupTestSuiteState TestSuiteState{..} = do + sessions <- modifyMVar testSuiteStateAvailableSessions $ \xs -> return ([], xs) + mapM_ (shutdownSession . snd) sessions + +{------------------------------------------------------------------------------- + Tasty additional command line options + + (used to configure the test suite) +-------------------------------------------------------------------------------} + +newtype TestSuiteOptionKeepTempFiles = TestSuiteOptionKeepTempFiles Bool + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionNoSessionReuse = TestSuiteOptionNoSessionReuse Bool + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionNoHaddocks = TestSuiteOptionNoHaddocks Bool + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionNoExe = TestSuiteOptionNoExe Bool + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionNoIntegration = TestSuiteOptionNoIntegration Bool + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionPackageDb74 = TestSuiteOptionPackageDb74 (Maybe String) + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionPackageDb78 = TestSuiteOptionPackageDb78 (Maybe String) + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionPackageDb710 = TestSuiteOptionPackageDb710 (Maybe String) + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionExtraPaths74 = TestSuiteOptionExtraPaths74 String + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionExtraPaths78 = TestSuiteOptionExtraPaths78 String + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionExtraPaths710 = TestSuiteOptionExtraPaths710 String + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionTest74 = TestSuiteOptionTest74 Bool + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionTest78 = TestSuiteOptionTest78 Bool + deriving (Eq, Ord, Typeable) +newtype TestSuiteOptionTest710 = TestSuiteOptionTest710 Bool + deriving (Eq, Ord, Typeable) + +instance IsOption TestSuiteOptionKeepTempFiles where + defaultValue = TestSuiteOptionKeepTempFiles False + parseValue = fmap TestSuiteOptionKeepTempFiles . safeRead + optionName = return "keep-temp-files" + optionHelp = return "Keep session temp files" + optionCLParser = flagCLParser Nothing (TestSuiteOptionKeepTempFiles True) + +instance IsOption TestSuiteOptionNoSessionReuse where + defaultValue = TestSuiteOptionNoSessionReuse False + parseValue = fmap TestSuiteOptionNoSessionReuse . safeRead + optionName = return "no-session-reuse" + optionHelp = return "Start a new session for each test" + optionCLParser = flagCLParser Nothing (TestSuiteOptionNoSessionReuse True) + +instance IsOption TestSuiteOptionNoHaddocks where + defaultValue = TestSuiteOptionNoHaddocks False + parseValue = fmap TestSuiteOptionNoHaddocks . safeRead + optionName = return "no-haddocks" + optionHelp = return "No haddock documentation installed on the test system" + optionCLParser = flagCLParser Nothing (TestSuiteOptionNoHaddocks True) + +instance IsOption TestSuiteOptionNoExe where + defaultValue = TestSuiteOptionNoExe False + parseValue = fmap TestSuiteOptionNoExe . safeRead + optionName = return "no-exe" + optionHelp = return "Skip buildExe tests" + optionCLParser = flagCLParser Nothing (TestSuiteOptionNoExe True) + +instance IsOption TestSuiteOptionNoIntegration where + defaultValue = TestSuiteOptionNoIntegration False + parseValue = fmap TestSuiteOptionNoIntegration . safeRead + optionName = return "no-integration" + optionHelp = return "Skip integration tests" + optionCLParser = flagCLParser Nothing (TestSuiteOptionNoIntegration True) + +instance IsOption TestSuiteOptionPackageDb74 where + defaultValue = TestSuiteOptionPackageDb74 Nothing + parseValue = Just . TestSuiteOptionPackageDb74 . Just . expandHomeDir + optionName = return "package-db-74" + optionHelp = return "Package DB stack for GHC 7.4" + +instance IsOption TestSuiteOptionPackageDb78 where + defaultValue = TestSuiteOptionPackageDb78 Nothing + parseValue = Just . TestSuiteOptionPackageDb78 . Just . expandHomeDir + optionName = return "package-db-78" + optionHelp = return "Package DB stack for GHC 7.8" + +instance IsOption TestSuiteOptionPackageDb710 where + defaultValue = TestSuiteOptionPackageDb710 Nothing + parseValue = Just . TestSuiteOptionPackageDb710 . Just . expandHomeDir + optionName = return "package-db-710" + optionHelp = return "Package DB stack for GHC 7.10" + +instance IsOption TestSuiteOptionExtraPaths74 where + defaultValue = TestSuiteOptionExtraPaths74 "" + parseValue = Just . TestSuiteOptionExtraPaths74 . expandHomeDir + optionName = return "extra-paths-74" + optionHelp = return "Package DB stack for GHC 7.4" + +instance IsOption TestSuiteOptionExtraPaths78 where + defaultValue = TestSuiteOptionExtraPaths78 "" + parseValue = Just . TestSuiteOptionExtraPaths78 . expandHomeDir + optionName = return "extra-paths-78" + optionHelp = return "Package DB stack for GHC 7.8" + +instance IsOption TestSuiteOptionExtraPaths710 where + defaultValue = TestSuiteOptionExtraPaths710 "" + parseValue = Just . TestSuiteOptionExtraPaths710 . expandHomeDir + optionName = return "extra-paths-710" + optionHelp = return "Package DB stack for GHC 7.10" + +instance IsOption TestSuiteOptionTest74 where + defaultValue = TestSuiteOptionTest74 False + parseValue = fmap TestSuiteOptionTest74 . safeRead + optionName = return "test-74" + optionHelp = return "Run tests against GHC 7.4" + optionCLParser = flagCLParser Nothing (TestSuiteOptionTest74 True) + +instance IsOption TestSuiteOptionTest78 where + defaultValue = TestSuiteOptionTest78 False + parseValue = fmap TestSuiteOptionTest78 . safeRead + optionName = return "test-78" + optionHelp = return "Run tests against GHC 7.8" + optionCLParser = flagCLParser Nothing (TestSuiteOptionTest78 True) + +instance IsOption TestSuiteOptionTest710 where + defaultValue = TestSuiteOptionTest710 False + parseValue = fmap TestSuiteOptionTest710 . safeRead + optionName = return "test-710" + optionHelp = return "Run tests against GHC 7.10" + optionCLParser = flagCLParser Nothing (TestSuiteOptionTest710 True) + +testSuiteCommandLineOptions :: [OptionDescription] +testSuiteCommandLineOptions = [ + Option (Proxy :: Proxy TestSuiteOptionKeepTempFiles) + , Option (Proxy :: Proxy TestSuiteOptionNoSessionReuse) + , Option (Proxy :: Proxy TestSuiteOptionNoHaddocks) + , Option (Proxy :: Proxy TestSuiteOptionNoExe) + , Option (Proxy :: Proxy TestSuiteOptionNoIntegration) + , Option (Proxy :: Proxy TestSuiteOptionPackageDb74) + , Option (Proxy :: Proxy TestSuiteOptionPackageDb78) + , Option (Proxy :: Proxy TestSuiteOptionPackageDb710) + , Option (Proxy :: Proxy TestSuiteOptionExtraPaths74) + , Option (Proxy :: Proxy TestSuiteOptionExtraPaths78) + , Option (Proxy :: Proxy TestSuiteOptionExtraPaths710) + , Option (Proxy :: Proxy TestSuiteOptionTest74) + , Option (Proxy :: Proxy TestSuiteOptionTest78) + , Option (Proxy :: Proxy TestSuiteOptionTest710) + ] + +parseOptions :: (TestSuiteConfig -> TestTree) -> TestTree +parseOptions f = + askOption $ \(TestSuiteOptionKeepTempFiles testSuiteConfigKeepTempFiles) -> + askOption $ \(TestSuiteOptionNoSessionReuse testSuiteConfigNoSessionReuse) -> + askOption $ \(TestSuiteOptionNoHaddocks testSuiteConfigNoHaddocks) -> + askOption $ \(TestSuiteOptionNoExe testSuiteConfigNoExe) -> + askOption $ \(TestSuiteOptionNoIntegration testSuiteConfigNoIntegration) -> + askOption $ \(TestSuiteOptionPackageDb74 testSuiteConfigPackageDb74) -> + askOption $ \(TestSuiteOptionPackageDb78 testSuiteConfigPackageDb78) -> + askOption $ \(TestSuiteOptionPackageDb710 testSuiteConfigPackageDb710) -> + askOption $ \(TestSuiteOptionExtraPaths74 testSuiteConfigExtraPaths74) -> + askOption $ \(TestSuiteOptionExtraPaths78 testSuiteConfigExtraPaths78) -> + askOption $ \(TestSuiteOptionExtraPaths710 testSuiteConfigExtraPaths710) -> + askOption $ \(TestSuiteOptionTest74 testSuiteConfigTest74) -> + askOption $ \(TestSuiteOptionTest78 testSuiteConfigTest78) -> + askOption $ \(TestSuiteOptionTest710 testSuiteConfigTest710) -> + f TestSuiteConfig{..} + +{------------------------------------------------------------------------------- + Test suite global state +-------------------------------------------------------------------------------} + +-- | Temporarily switch directory +-- +-- (and make sure to switch back even in the presence of exceptions) +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory fp act = + requireExclusiveAccess $ + bracket (do cwd <- getCurrentDirectory + setCurrentDirectory fp + return cwd) + (setCurrentDirectory) + (\_ -> act) + +findExe :: TestSuiteEnv -> String -> IO FilePath +findExe TestSuiteEnv{..} name = do + mLoc <- OurCabal.findProgramOnSearchPath minBound searchPath name + case mLoc of + Nothing -> fail $ "Could not find " ++ name + Just prog -> return prog + where + extraPathDirs = + case testSuiteEnvGhcVersion of + GHC_7_4 -> testSuiteConfigExtraPaths74 testSuiteEnvConfig + GHC_7_8 -> testSuiteConfigExtraPaths78 testSuiteEnvConfig + GHC_7_10 -> testSuiteConfigExtraPaths710 testSuiteEnvConfig + + searchPath :: OurCabal.ProgramSearchPath + searchPath = OurCabal.ProgramSearchPathDefault + : map OurCabal.ProgramSearchPathDir (splitSearchPath extraPathDirs) + +withInstalledPackage :: TestSuiteEnv -> FilePath -> IO a -> IO a +withInstalledPackage env pkgDir act = + requireExclusiveAccess $ + bracket_ (packageInstall env pkgDir) + (packageDelete env pkgDir) + act + +-- | Used only in the definition of 'withInstalledPackage' +-- +-- This should not be used in isolation because it changes test global state. +packageInstall :: TestSuiteEnv -> FilePath -> IO () +packageInstall env@TestSuiteEnv{..} pkgDir = do + cabalExe <- findExe env "cabal" + oldEnv <- System.Environment.getEnvironment + let oldEnvMap = Map.fromList oldEnv + adjustPATH oldPATH = extraPathDirs ++ ":" ++ oldPATH + newEnvMap = Map.adjust adjustPATH "PATH" oldEnvMap + newEnv = Map.toList newEnvMap + (_,_,_,r2) <- createProcess (proc cabalExe opts) + { cwd = Just pkgDir + , env = Just newEnv + } + void $ waitForProcess r2 + where + extraPathDirs = + case testSuiteEnvGhcVersion of + GHC_7_4 -> testSuiteConfigExtraPaths74 testSuiteEnvConfig + GHC_7_8 -> testSuiteConfigExtraPaths78 testSuiteEnvConfig + GHC_7_10 -> testSuiteConfigExtraPaths710 testSuiteEnvConfig + packageDb = fromMaybe "" $ + case testSuiteEnvGhcVersion of + GHC_7_4 -> testSuiteConfigPackageDb74 testSuiteEnvConfig + GHC_7_8 -> testSuiteConfigPackageDb78 testSuiteEnvConfig + GHC_7_10 -> testSuiteConfigPackageDb710 testSuiteEnvConfig + + opts = [ "--no-require-sandbox" + , "install" + , "--package-db=" ++ packageDb + , "--disable-library-profiling" + , "-v0" + ] + + +-- | Used only in the definition of 'withInstalledPackage' +-- +-- This should not be used in isolation because it changes test global state. +packageDelete :: TestSuiteEnv -> FilePath -> IO () +packageDelete env@TestSuiteEnv{..} pkgDir = do + ghcPkgExe <- findExe env "ghc-pkg" + (_,_,_,r2) <- createProcess (proc ghcPkgExe opts) + { cwd = Just pkgDir + , std_err = CreatePipe + } + void $ waitForProcess r2 + where + packageDb = fromMaybe "" $ + case testSuiteEnvGhcVersion of + GHC_7_4 -> testSuiteConfigPackageDb74 testSuiteEnvConfig + GHC_7_8 -> testSuiteConfigPackageDb78 testSuiteEnvConfig + GHC_7_10 -> testSuiteConfigPackageDb710 testSuiteEnvConfig + + opts = [ "--package-conf=" ++ packageDb, "-v0", "unregister" + , takeFileName pkgDir + ] + + +-- TODO: We need to be careful with concurrency here +-- +-- See comments for packageDelete. +packageCheck :: TestSuiteEnv -> FilePath -> IO String +packageCheck env pkgDir = do + cabalExe <- findExe env "cabal" + (_, mlocal_std_out, _, r2) + <- createProcess (proc cabalExe ["check"]) + { cwd = Just pkgDir + , std_out = CreatePipe + } + let local_std_out = fromJust mlocal_std_out + checkWarns <- hGetContents local_std_out + evaluate $ rnf checkWarns + hClose local_std_out + void $ waitForProcess r2 + return checkWarns + +{------------------------------------------------------------------------------- + Concurrency control +-------------------------------------------------------------------------------} + +-- | We run many tests concurrently, but occassionally a test needs to modify +-- the test global state (for instance, it might need to modify the current +-- working directory temporarily). When this happens, no other tests should +-- currently be executing. +data TestSuiteThreads = + -- | Normal execution of multiple threads, none of have exclusive access + -- right now + -- + -- We record the set of running threads as well as the set of threads + -- waiting to gain exclusive access, so that we don't start new threads + -- when there are other threads waiting for exclusive access. + NormalExecution [ThreadId] [ThreadId] + + -- | A thread currently has exclusive access + -- + -- We record which other threads were waiting to gain exclusive access + | ExclusiveExecution [ThreadId] + deriving Show + +testSuiteThreadsTVar :: TVar TestSuiteThreads +{-# NOINLINE testSuiteThreadsTVar #-} +testSuiteThreadsTVar = unsafePerformIO $ newTVarIO $ NormalExecution [] [] + +-- | Every test execution should be wrapped in registerTest +registerTest :: TestName -> IO a -> IO a +registerTest _name act = do + tid <- myThreadId + bracket_ (register tid) (unregister tid) act + where + register :: ThreadId -> IO () + register t = atomically $ do + testSuiteThreads <- readTVar testSuiteThreadsTVar + case testSuiteThreads of + NormalExecution running waiting -> do + -- Don't start if there are threads waiting for exclusive access + guard (waiting == []) + writeTVar testSuiteThreadsTVar $ NormalExecution (t:running) [] + ExclusiveExecution _ -> + -- Some other thread currently needs exclusive access.. Wait. + retry + + unregister :: ThreadId -> IO () + unregister t = atomically $ do + testSuiteThreads <- readTVar testSuiteThreadsTVar + case testSuiteThreads of + NormalExecution running waiting -> do + let Just (_, running') = extract (== t) running + writeTVar testSuiteThreadsTVar $ NormalExecution running' waiting + ExclusiveExecution _ -> + -- This should never happen + error "The impossible happened" + +requireExclusiveAccess :: IO a -> IO a +requireExclusiveAccess act = do + tid <- myThreadId + bracket_ (lock tid) (unlock tid) act + where + lock :: ThreadId -> IO () + lock t = do + -- Record that we are no longer running, but are waiting + atomically $ do + testSuiteThreads <- readTVar testSuiteThreadsTVar + case testSuiteThreads of + NormalExecution running waiting -> do + let Just (_, running') = extract (== t) running + waiting' = t : waiting + writeTVar testSuiteThreadsTVar $ NormalExecution running' waiting' + ExclusiveExecution _ -> + error "lock: the impossible happened" + + -- Wait until there are no more threads running (i.e., all other threads + -- have terminated or are themselves waiting to get exclusive access) + atomically $ do + testSuiteThreads <- readTVar testSuiteThreadsTVar + case testSuiteThreads of + NormalExecution [] waiting -> do + let Just (_, waiting') = extract (== t) waiting + writeTVar testSuiteThreadsTVar (ExclusiveExecution waiting') + _ -> retry + + unlock :: ThreadId -> IO () + unlock t = do + -- Give up exclusive access + atomically $ do + testSuiteThreads <- readTVar testSuiteThreadsTVar + case testSuiteThreads of + NormalExecution _ _ -> + error "unlock: the impossible happened" + ExclusiveExecution waiting -> + writeTVar testSuiteThreadsTVar (NormalExecution [] waiting) + + -- And try to start running again + atomically $ do + testSuiteThreads <- readTVar testSuiteThreadsTVar + case testSuiteThreads of + NormalExecution running waiting -> do + -- Don't start if there are threads waiting for exclusive access + guard (waiting == []) + writeTVar testSuiteThreadsTVar $ NormalExecution (t:running) [] + ExclusiveExecution _ -> + -- Some other thread currently needs exclusive access.. Wait. + retry + +{------------------------------------------------------------------------------- + Paths + + TODO: Currently all tests hardcode the "TestSuite/inputs" path. We should + define testInputPath here and use it throughout. +-------------------------------------------------------------------------------} + +testInputPathCabal :: TestSuiteEnv -> FilePath +testInputPathCabal env = + case testSuiteEnvGhcVersion env of + GHC_7_4 -> "TestSuite/inputs/Cabal-1.14.0" + GHC_7_8 -> "TestSuite/inputs/Cabal-1.18.1.5" + GHC_7_10 -> "TestSuite/inputs/Cabal-1.22.0.0" + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +extractMVar :: (a -> Bool) -> MVar [a] -> IO (Maybe a) +extractMVar p listMVar = do + modifyMVar listMVar $ \xs -> + case extract p xs of + Just (x, xs') -> return (xs', Just x) + Nothing -> return (xs, Nothing) + +consMVar :: a -> MVar [a] -> IO () +consMVar x listMVar = modifyMVar_ listMVar $ \xs -> return (x : xs) + +extract :: (a -> Bool) -> [a] -> Maybe (a, [a]) +extract _ [] = Nothing +extract p (x:xs) | p x = return (x, xs) + | otherwise = do (mx, xs') <- extract p xs + return (mx, x : xs') + +expandHomeDir :: FilePath -> FilePath +expandHomeDir path = unsafePerformIO $ do + home <- getHomeDirectory + + let expand :: FilePath -> FilePath + expand [] = [] + expand ('~':xs) = home ++ expand xs + expand (x:xs) = x : expand xs + + return $ expand path + +-- Check that the specified directory contains no files +-- (it may however contain subdirectories) +checkIsEmpty :: [String] -> FilePath -> IO () +checkIsEmpty ignoredExtensions = go + where + go :: FilePath -> IO () + go parent = do + children <- filter (not . ignore) `liftM` getDirectoryContents parent + forM_ children $ \relChild -> + unless (takeExtension relChild `elem` ignoredExtensions) $ do + let absChild = parent relChild + isFile <- doesFileExist absChild + isDir <- doesDirectoryExist absChild + when isFile $ throwIO (userError ("unexpected file " ++ relChild ++ " in " ++ parent)) + when isDir $ go absChild + + ignore :: FilePath -> Bool + ignore "." = True + ignore ".." = True + ignore _ = False diff --git a/TestSuite/TestSuite/Tests/API.hs b/TestSuite/TestSuite/Tests/API.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/API.hs @@ -0,0 +1,381 @@ +-- Test use and abuse of the ide-backend API (such as two calls to shutdown etc) +-- +-- Since many of these tests have a non-standard use of the API they often do +-- not use the withAvailableSession infrastructure. +module TestSuite.Tests.API (testGroupAPI) where + +import Control.Concurrent +import Control.Exception +import Data.Monoid +import System.Exit +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.Lazy.Char8 as L (unlines) +import qualified Data.Text as T + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupAPI :: TestSuiteEnv -> TestTree +testGroupAPI env = testGroup "API use and abuse" $ [ + stdTest env "Duplicate shutdown" testDuplicateShutdown + , stdTest env "Permit a session within a session and duplicated shutdownSession" testNestedSessions + , stdTest env "Reject updateSession after shutdownSession" testRejectUpdateSession + , stdTest env "Reject getSourceErrors after shutdownSession" testRejectGetSourceErrors + , stdTest env "Reject runStmt after shutdownSession" testRejectRunStmt + , stdTest env "Fail on empty package DB" testEmptyPackageDB + , stdTest env "Two calls to runStmt" testTwiceRunStmt + , stdTest env "Make sure we can terminate the IDE session when code is running" test_Terminate_CodeRunning + , stdTest env "getSourceErrors during run" test_getSourceErrors_CodeRunning + , stdTest env "getLoadedModules during run" test_getLoadedModules_CodeRunning + , stdTest env "getLoadedModules while configGenerateModInfo off" test_getLoadedModules_ConfigGenerateModInfoOff + , stdTest env "Call runWait after termination (normal termination)" test_runWait_AfterTermination + , stdTest env "Call runWait after termination (interrupted)" test_runWait_AfterTermination_Int + , stdTest env "Call runWait after termination (restarted session)" test_runWait_AfterTermination_Restarted + ] ++ exeTests env [ + stdTest env "Two calls to runExe" testTwiceRunExe + , stdTest env "Make sure we can terminate the IDE session when exe is running" test_Terminate_ExeRunning + ] + +testDuplicateShutdown :: TestSuiteEnv -> Assertion +testDuplicateShutdown env = + withSession (defaultServerConfig env) $ + -- withSession itself also does a shutdownSession + shutdownSession + +testNestedSessions :: TestSuiteEnv -> Assertion +testNestedSessions env = + withSession (defaultServerConfig env) $ \session -> do + loadModulesFrom session "TestSuite/inputs/ABnoError" + + withSession (defaultServerConfig env) $ \s2 -> do + withSession (defaultServerConfig env) $ \s3 -> do + withSession (defaultServerConfig env) $ \_s4 -> do + let update2 = loadModule "M.hs" "a = unknownX" + updateSessionD s2 update2 1 + assertOneError s2 + withSession (defaultServerConfig env) $ \s5 -> do + let update3 = loadModule "M.hs" "a = 3" + updateSessionD s3 update3 1 + assertNoErrors session + shutdownSession s5 -- <-- duplicate "nested" shutdown + +testRejectUpdateSession :: TestSuiteEnv -> Assertion +testRejectUpdateSession env = + withSession (defaultServerConfig env) $ \session -> do + shutdownSession session + assertRaises "updateSessionD session mempty" + (== userError "Session already shut down.") + (updateSessionD session mempty 0) + +testRejectGetSourceErrors :: TestSuiteEnv -> Assertion +testRejectGetSourceErrors env = + withSession (defaultServerConfig env) $ \session -> do + shutdownSession session + assertRaises "getSourceErrors session" + (== userError "Session already shut down.") + (getSourceErrors session) + +testRejectRunStmt :: TestSuiteEnv -> Assertion +testRejectRunStmt env = + withSession (defaultServerConfig env) $ \session -> do + shutdownSession session + assertRaises "runStmt session Main main" + (== userError "State not idle") + (runStmt session "Main" "main") + +testEmptyPackageDB :: TestSuiteEnv -> Assertion +testEmptyPackageDB env = + assertRaises "" + (\e -> e == userError "Invalid package DB stack: []") + (withSession cfg $ \_ -> return ()) + where + cfg = (defaultServerConfig env) { + testSuiteServerPackageDBStack = Just [] + } + +testTwiceRunStmt :: TestSuiteEnv -> Assertion +testTwiceRunStmt env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + do runActions <- runStmt session "M" "echo" + supplyStdin runActions "ECHO!\n" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "ECHO!\n" output + + do runActions <- runStmt session "M" "echoReverse" + supplyStdin runActions "!OHCE\n" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "ECHO!\n" output + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "echo :: IO ()" + , "echo = getLine >>= putStrLn" + , "echoReverse :: IO ()" + , "echoReverse = getLine >>= putStrLn . reverse" + ]) + +testTwiceRunExe :: TestSuiteEnv -> Assertion +testTwiceRunExe env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + + do runActions <- runExe session "M" + supplyStdin runActions "!OHCE\n" + (output, result) <- runWaitAll runActions + assertEqual "" result ExitSuccess + assertEqual "" "ECHO!\n" output + + do runActions <- runExe session "M" + supplyStdin runActions "!OHCE\n" + (output, result) <- runWaitAll runActions + assertEqual "" result ExitSuccess + assertEqual "" "ECHO!\n" output + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "main :: IO ()" + , "main = getLine >>= putStrLn . reverse" + ]) + +test_Terminate_CodeRunning :: TestSuiteEnv -> Assertion +test_Terminate_CodeRunning env = do + runActions <- withAvailableSession' env dontReuse $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runStmt session "M" "echo" + forceCancel runActions + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "echo :: IO ()" + , "echo = (getLine >>= putStrLn) >> echo" + ]) + +test_Terminate_ExeRunning :: TestSuiteEnv -> Assertion +test_Terminate_ExeRunning env = do + runActions <- withAvailableSession' env dontReuse $ \session -> do + updateSessionD session upd 1 + + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + + assertNoErrors session + runExe session "M" + forceCancel runActions + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "main :: IO ()" + , "main = (getLine >>= putStrLn) >> main" + ]) + +test_getSourceErrors_CodeRunning :: TestSuiteEnv -> Assertion +test_getSourceErrors_CodeRunning env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertSourceErrors' session ["Top-level binding with no type signature"] + errs <- getSourceErrors session + + do runActions <- runStmt session "M" "loop" + errs' <- getSourceErrors session + assertEqual "Running code does not affect getSourceErrors" errs errs' + forceCancel runActions + + ifTestingExe env $ do + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + + updateSessionD session updExe 2 + errs' <- getSourceErrors session + assertEqual "" errs errs' + + runActions <- runExe session m + errs'' <- getSourceErrors session + assertEqual "Running exes does not affect getSourceErrors" errs errs'' + + forceCancel runActions + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "{-# OPTIONS_GHC -Wall #-}" + , "module M where" + , "loop = loop" + , "main :: IO ()" + , "main = loop" + ]) + +test_getLoadedModules_CodeRunning :: TestSuiteEnv -> Assertion +test_getLoadedModules_CodeRunning env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + mods <- getLoadedModules session + assertEqual "" [T.pack "M"] mods + + runActions <- runStmt session "M" "loop" + mods' <- getLoadedModules session + assertEqual "Running code does not affect getLoadedModules" mods mods' + forceCancel runActions + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "{-# OPTIONS_GHC -Wall #-}" + , "module M where" + , "loop = loop" + ]) + +test_runWait_AfterTermination :: TestSuiteEnv -> Assertion +test_runWait_AfterTermination env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + do runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Hello World\n" output + result' <- runWait runActions + assertEqual "" result' (Right RunOk) + + ifTestingExe env $ do + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "Hello World\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + + result2 <- runWait runActionsExe + assertEqual "" result2 (Right ExitSuccess) + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "hello :: IO ()" + , "hello = putStrLn \"Hello World\"" + , "main :: IO ()" + , "main = hello" + ]) + +test_runWait_AfterTermination_Int :: TestSuiteEnv -> Assertion +test_runWait_AfterTermination_Int env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + do runActions <- runStmt session "M" "loop" + threadDelay 1000000 + interrupt runActions + resOrEx <- runWait runActions + case resOrEx of + Right result -> assertBool "" (isAsyncException result) + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx + resOrEx' <- runWait runActions + case resOrEx' of + Right result -> assertBool "" (isAsyncException result) + _ -> assertFailure $ "Unexpected run result in repeat call: " ++ show resOrEx' + + ifTestingExe env $ do + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + threadDelay 1000000 + interrupt runActionsExe + resOrEx <- runWait runActionsExe + case resOrEx of + Right result -> assertEqual "after runExe" (ExitFailure (-2)) result -- SIGINT + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx + result' <- runWait runActionsExe + assertEqual "" result' (Right $ ExitFailure (-2)) -- SIGINT + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Control.Concurrent (threadDelay)" + , "loop :: IO ()" + , "loop = threadDelay 100000 >> loop" + , "main :: IO ()" + , "main = loop" + ]) + +test_runWait_AfterTermination_Restarted :: TestSuiteEnv -> Assertion +test_runWait_AfterTermination_Restarted env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + do runActions <- runStmt session "M" "loop" + threadDelay 1000000 + restartSession session + forceCancel runActions + resOrEx2 <- runWait runActions + case resOrEx2 of + Right RunForceCancelled -> return () + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx2 + resOrEx' <- runWait runActions + case resOrEx' of + Right RunForceCancelled -> return () + _ -> assertFailure $ "Unexpected run result in repeat call: " ++ show resOrEx' + + updateSessionD session mempty 1 -- needed to load the code again + + ifTestingExe env $ do + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 3 -- TODO: Really we only expect 2 (#189) + runActionsExe <- runExe session m + threadDelay 1000000 + restartSession session + -- restartSession would not suffice, since session restart + -- doesn't stop the exe, so we need to interrupt manually. + interrupt runActionsExe + resOrEx <- runWait runActionsExe + case resOrEx of + Right result -> assertEqual "after runExe" (ExitFailure (-2)) result -- SIGKILL + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx + result' <- runWait runActionsExe + assertEqual "" result' (Right $ ExitFailure (-2)) -- SIGKILL + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Control.Concurrent (threadDelay)" + , "loop :: IO ()" + , "loop = threadDelay 100000 >> loop" + , "main :: IO ()" + , "main = loop" + ]) + +test_getLoadedModules_ConfigGenerateModInfoOff :: TestSuiteEnv -> Assertion +test_getLoadedModules_ConfigGenerateModInfoOff env = withAvailableSession' env (withModInfo False) $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + assertLoadedModules session "" ["M"] + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "hello :: IO ()" + , "hello = putStrLn \"Hello World\"" + ]) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +withSession :: TestSuiteServerConfig -> (IdeSession -> IO a) -> IO a +withSession cfg = bracket (startNewSession cfg) shutdownSession diff --git a/TestSuite/TestSuite/Tests/Autocompletion.hs b/TestSuite/TestSuite/Tests/Autocompletion.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/Autocompletion.hs @@ -0,0 +1,212 @@ +module TestSuite.Tests.Autocompletion (testGroupAutocompletion) where + +import Prelude hiding (mod, span) +import Data.Maybe +import Data.Monoid +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.Lazy.Char8 as L (unlines) +import qualified Data.Text as T + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +-- TODO: Autocomplete test that checks import errors: +-- +-- * Explicitly importing something that wasn't exported +-- * Explicitly hiding something that wasn't exported +-- * Use of PackageImports without the flag +testGroupAutocompletion :: TestSuiteEnv -> TestTree +testGroupAutocompletion env = testGroup "Autocompletion" $ [ + stdTest env "Imports for partial module" test_PartialModule + , stdTest env "Recompute after recompilation" test_Recompute + , stdTest env "fpco issue #2518" test_2518 + ] ++ docTests env [ + stdTest env "Autocompletion entries should have home module info" test_HomeModuleInfo + ] + +test_PartialModule :: TestSuiteEnv -> Assertion +test_PartialModule env = withAvailableSession' env (withGhcOpts ["-XPackageImports"]) $ \session -> do + updateSessionD session upd 1 + assertSourceErrors' session ["parse error"] + imports <- getImports session + + assertSameSet "imports: " (ignoreVersions . fromJust . imports $ "M") $ [ + Import { + importModule = base "Prelude" + , importPackage = Nothing + , importQualified = False + , importImplicit = True + , importAs = Nothing + , importEntities = ImportAll + } + , Import { + importModule = base "Control.Monad" + , importPackage = Nothing + , importQualified = False + , importImplicit = False + , importAs = Nothing + , importEntities = ImportAll + } + , Import { + importModule = base "Control.Category" + , importPackage = Nothing + , importQualified = False + , importImplicit = False + , importAs = Nothing + , importEntities = ImportHiding ["id"] + } + , Import { + importModule = base "Control.Arrow" + , importPackage = Nothing + , importQualified = True + , importImplicit = False + , importAs = Just "A" + , importEntities = ImportOnly ["second"] + } + , Import { + importModule = base "Data.List" + , importPackage = Just "base" + , importQualified = True + , importImplicit = False + , importAs = Nothing + , importEntities = ImportAll + } + , Import { + importModule = par "Control.Parallel" + , importPackage = Nothing + , importQualified = False + , importImplicit = False + , importAs = Nothing + , importEntities = ImportAll + } + ] + autocomplete <- getAutocompletion session + let completeFo = autocomplete "M" "fo" + assertSameSet "fo: " (map idInfoQN completeFo) ([ + "foldM" + , "foldM_" + , "forM" + , "forM_" + , "forever" + , "Data.List.foldl'" + , "Data.List.foldl1" + , "Data.List.foldl1'" + , "Data.List.foldr" + , "Data.List.foldl" + , "Data.List.foldr1" + ] ++ if testSuiteEnvGhcVersion env < GHC_7_10 then [] else [ + "foldMap" + ]) + let completeControlMonadFo = autocomplete "M" "Data.List.fo" + assertSameSet "Data.List.fo: " (map idInfoQN completeControlMonadFo) [ + "Data.List.foldl'" + , "Data.List.foldl1" + , "Data.List.foldl1'" + , "Data.List.foldr" + , "Data.List.foldl" + , "Data.List.foldr1" + ] + let completeSec = autocomplete "M" "sec" + assertSameSet "sec: " (map idInfoQN completeSec) [ + "A.second" + ] + where + upd = (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Control.Monad" + , "import Control.Category hiding (id)" + , "import qualified Control.Arrow as A (second)" + , "import qualified \"base\" Data.List" + , "import Control.Parallel" + , "foo =" + ]) + + -- ignoreVersions sets the key to be equal to the name + base mod = ModuleId { + moduleName = T.pack mod + , modulePackage = PackageId { + packageName = "base" + , packageVersion = Just "X.Y.Z" + , packageKey = "base" + } + } + par mod = ModuleId { + moduleName = T.pack mod + , modulePackage = PackageId { + packageName = "parallel" + , packageVersion = Just "X.Y.Z" + , packageKey = "parallel" + } + } + +test_Recompute :: TestSuiteEnv -> Assertion +test_Recompute env = withAvailableSession env $ \session -> do + updateSessionD session upd 2 + assertNoErrors session + + -- First check, for sanity + do autocomplete <- getAutocompletion session + let completeFoob = autocomplete "B" "foob" + assertEqual "" "[foobar (VarName) :: Bool -> Bool defined in main:A at A.hs@3:1-3:7 (imported from main:A at B.hs@2:1-2:9)]" (show completeFoob) + + -- Change A, but not B. The type reported in the autocompletion for B + -- should now be changed, too + -- This will trigger recompilation of B + updateSessionD session upd' 2 + assertNoErrors session + + do autocomplete <- getAutocompletion session + let completeFoob = autocomplete "B" "foob" + let expected = "[foobar (VarName) :: Int -> Int defined in main:A at A.hs@3:1-3:7 (imported from main:A at B.hs@2:1-2:9),foobar' (VarName) :: () -> () defined in main:A at A.hs@5:1-5:8 (imported from main:A at B.hs@2:1-2:9)]" + assertEqual "" expected (show completeFoob) + where + upd = (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "foobar :: Bool -> Bool" + , "foobar = id" + ]) + <> (updateSourceFile "B.hs" . L.unlines $ + [ "module B where" + , "import A" + ]) + + upd' = (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "foobar :: Int -> Int" + , "foobar = id" + , "foobar' :: () -> ()" + , "foobar' = id" + ]) + +test_HomeModuleInfo :: TestSuiteEnv -> Assertion +test_HomeModuleInfo env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + autocomplete <- getAutocompletion session + let completeTru = autocomplete "A" "Tru" + assertEqual "" (ignoreVersions "[True (DataName) defined in ghc-prim-0.2.0.0:GHC.Types at (home base-4.5.1.0:Data.Bool) (wired in to the compiler)]") (ignoreVersions $ show completeTru) + where + upd = (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + ]) + + +test_2518 :: TestSuiteEnv -> Assertion +test_2518 env = withAvailableSession' env (withGhcOpts ["-XPackageImports"]) $ \session -> do + updateSessionD session upd 1 + assertSourceErrors' session ["Not in scope: `toC'"] + autocomplete <- getAutocompletion session + let complete_toC = autocomplete "M" "toC" + assertSameSet "" (map idInfoQN complete_toC) [ + "B.toChunks" + ] + where + upd = (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import qualified Data.ByteString.Lazy as B" + , "foo = toC" + ]) diff --git a/TestSuite/TestSuite/Tests/BufferMode.hs b/TestSuite/TestSuite/Tests/BufferMode.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/BufferMode.hs @@ -0,0 +1,121 @@ +module TestSuite.Tests.BufferMode (testGroupBufferMode) where + +import Data.List (partition) +import Data.Monoid +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.UTF8 as S +import qualified Data.ByteString.Lazy.Char8 as L (unlines) + +import IdeSession +import TestSuite.Assertions +import TestSuite.Session +import TestSuite.State + +testGroupBufferMode :: TestSuiteEnv -> TestTree +testGroupBufferMode env = testGroup "Buffer modes" [ + stdTest env "Buffer modes: RunNoBuffering" test_RunNoBuffering + , stdTest env "Buffer modes: RunLineBuffering, no timeout" test_RunLineBuffering_NoTimeout + , stdTest env "Buffer modes: RunBlockBuffering, no timeout" test_RunBlockBuffering_NoTimeout + , stdTest env "Buffer modes: RunLineBuffering, with timeout" test_RunLineBuffering_Timeout + , stdTest env "Buffer modes: RunBlockBuffering, with timeout" test_RunBlockBuffering_Timeout + , stdTest env "Buffer modes: RunBlockBuffering, buffer never fills, with timeout" test_RunBlockBuffering_Timeout_BufferNeverFills + ] + +test_RunNoBuffering :: TestSuiteEnv -> Assertion +test_RunNoBuffering env = testBufferMode env RunNoBuffering + +test_RunLineBuffering_NoTimeout :: TestSuiteEnv -> Assertion +test_RunLineBuffering_NoTimeout env = testBufferMode env (RunLineBuffering Nothing) + +test_RunBlockBuffering_NoTimeout :: TestSuiteEnv -> Assertion +test_RunBlockBuffering_NoTimeout env = testBufferMode env (RunBlockBuffering (Just 5) Nothing) + +test_RunLineBuffering_Timeout :: TestSuiteEnv -> Assertion +test_RunLineBuffering_Timeout env = testBufferMode env (RunLineBuffering (Just 1000000)) + +test_RunBlockBuffering_Timeout :: TestSuiteEnv -> Assertion +test_RunBlockBuffering_Timeout env = testBufferMode env (RunBlockBuffering (Just 4) (Just 1000000)) + +test_RunBlockBuffering_Timeout_BufferNeverFills :: TestSuiteEnv -> Assertion +test_RunBlockBuffering_Timeout_BufferNeverFills env = testBufferMode env (RunBlockBuffering (Just 4096) (Just 1000000)) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +testBufferMode :: TestSuiteEnv -> RunBufferMode -> Assertion +testBufferMode env bufferMode = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + runActions <- runStmt session "M" "printCs" + let go acc = do ret <- runWait runActions + case ret of + Left bs -> do + go (S.toString bs : acc) + Right RunOk -> + verify bufferMode (reverse acc) + Right res -> + assertFailure $ "Program terminated abnormally: " ++ show res + go [] + where + upd = (updateCodeGeneration True) + <> (updateStdoutBufferMode bufferMode) + <> (updateStderrBufferMode bufferMode) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Control.Concurrent" + , "import Control.Monad" + , "printCs :: IO ()" + , "printCs = do" + , " threadDelay 500000" + , " replicateM_ 5 $ do" + , " forM_ ['1' .. '9'] $ \\ch -> do" + , " threadDelay 100000" + , " putChar ch" + , " threadDelay 100000" + , " putChar '\\n'" + ]) + + verify :: RunBufferMode -> [String] -> Assertion + verify RunNoBuffering outp = + assertEqual "" (chunk 1 total) outp + verify (RunLineBuffering Nothing) outp = + assertEqual "" (chunkOn '\n' total) outp + verify (RunBlockBuffering (Just blockSize) Nothing) outp = + assertEqual "" (chunk blockSize total) outp + verify (RunLineBuffering (Just 1000000)) outp = do + -- We don't want to be *too* precise, but we should expect 10 chunks, + -- half of which should end on a linebreak. And of course they should + -- total to the right thing :) + let (withBreak, withoutBreak) = partition ((== '\n') . last) outp + assertEqual "" 5 (length withBreak) + assertEqual "" 5 (length withoutBreak) + assertEqual "" total (concat outp) + verify (RunBlockBuffering (Just 4) (Just 1000000)) outp = do + -- As above, we don't want to be too precise. Certaily no chunks should + -- be larger than 4, and "some" should be smaller + assertBool "" (all ((<= 4) . length) outp) + assertBool "" (any ((< 4) . length) outp) + assertEqual "" total (concat outp) + verify (RunBlockBuffering (Just 4096) (Just 1000000)) outp = do + assertEqual "" 6 (length outp) + assertEqual "" total (concat outp) + verify mode _outp = + assertFailure $ "Unsupported mode " ++ show mode + + total :: String + total = concat $ replicate 5 "123456789\n" + + chunk :: Int -> [a] -> [[a]] + chunk _ [] = [] + chunk n xs = let (firstChunk, rest) = splitAt n xs + in firstChunk : chunk n rest + + chunkOn :: Eq a => a -> [a] -> [[a]] + chunkOn _ [] = [] + chunkOn x xs = let (firstChunk, rest) = span (/= x) xs + in case rest of + (x' : rest') -> (firstChunk ++ [x']) : chunkOn x rest' + [] -> [firstChunk] diff --git a/TestSuite/TestSuite/Tests/BuildDoc.hs b/TestSuite/TestSuite/Tests/BuildDoc.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/BuildDoc.hs @@ -0,0 +1,86 @@ +module TestSuite.Tests.BuildDoc (testGroupBuildDoc) where + +import Control.Monad +import System.Directory +import System.Exit +import System.FilePath +import Test.Tasty +import Test.HUnit + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupBuildDoc :: TestSuiteEnv -> TestTree +testGroupBuildDoc env = testGroup "Build haddocks" [ + stdTest env "From some .lhs with relativeIncludes" + (test_fromLhsFiles True) + , stdTest env "From some .lhs files" (test_fromLhsFiles False) + , stdTest env "Fail" test_fail + , stdTest env "From ParFib with relativeIncludes" + (test_ParFib True) + , stdTest env "From ParFib files" (test_ParFib False) + ] + +test_fromLhsFiles :: Bool -> TestSuiteEnv -> Assertion +test_fromLhsFiles relativeIncludes env = withAvailableSession env + $ \session -> do + when relativeIncludes $ + updateSessionD session (updateRelativeIncludes ["", "Subdir"]) 0 + status0 <- getBuildDocStatus session + when relativeIncludes $ assertEqual "before module loading" Nothing status0 + withCurrentDirectory "TestSuite/inputs/compiler/utils" $ loadModulesFrom session "." + assertNoErrors session + let upd = buildDoc + updateSessionD session upd 1 + distDir <- getDistDir session + docStderr <- readFile $ distDir "doc/ide-backend-doc.stderr" + assertEqual "doc stderr empty" "" docStderr + status1 <- getBuildDocStatus session + assertEqual "after doc build" (Just ExitSuccess) status1 + indexExists <- doesFileExist $ distDir "doc/html/main/index.html" + assertBool ".lhs haddock files" indexExists + hoogleExists <- doesFileExist $ distDir "doc/html/main/main-1.0.txt" + assertBool ".lhs hoogle files" hoogleExists + mainExists <- doesFileExist $ distDir "doc/html/main/Main.html" + when relativeIncludes $ assertBool ".lhs Main haddock file" mainExists + +test_fail :: TestSuiteEnv -> Assertion +test_fail env = withAvailableSession env $ \session -> do + withCurrentDirectory "TestSuite/inputs/ABerror" $ loadModulesFrom session "." + assertOneError session + let upd = buildDoc + -- Note that the stderr log file here is empty, but exit code is 1: + updateSessionD session upd 1 + status1 <- getBuildDocStatus session + assertEqual "failure after doc build" (Just $ ExitFailure 1) status1 + +test_ParFib :: Bool -> TestSuiteEnv -> Assertion +test_ParFib relativeIncludes env = withAvailableSession env $ \session -> do + -- Warning: this also results in @compiler/@ written to the top-level + -- session directory. Unless it breaks other tests, let's keep it, + -- so that we see what happens with strange @updateRelativeIncludes@ + -- arguments and notice if other changes to code cause any larger breakage. + when relativeIncludes $ + updateSessionD session + (updateRelativeIncludes ["", "../compiler/utils/Subdir"]) + 0 + withCurrentDirectory "TestSuite/inputs/MainModule" $ loadModulesFrom session "." + when relativeIncludes $ + withCurrentDirectory "TestSuite/inputs/MainModule" $ + loadModulesFrom session "../compiler/utils/Subdir" + assertNoErrors session + let upd = buildDoc + updateSessionD session upd 1 + distDir <- getDistDir session + docStderr <- readFile $ distDir "doc/ide-backend-doc.stderr" + assertEqual "doc stderr empty" "" docStderr + status1 <- getBuildDocStatus session + assertEqual "after doc build" (Just ExitSuccess) status1 + indexExists <- doesFileExist $ distDir "doc/html/main/index.html" + assertBool "ParFib haddock files" indexExists + hoogleExists <- doesFileExist $ distDir "doc/html/main/main-1.0.txt" + assertBool "ParFib hoogle files" hoogleExists + mainExists <- doesFileExist $ distDir "doc/html/main/Main.html" + when relativeIncludes $ assertBool ".lhs Main haddock file" mainExists diff --git a/TestSuite/TestSuite/Tests/BuildExe.hs b/TestSuite/TestSuite/Tests/BuildExe.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/BuildExe.hs @@ -0,0 +1,286 @@ +module TestSuite.Tests.BuildExe (testGroupBuildExe) where + +import Data.Monoid +import System.FilePath +import System.Exit +import System.Process +import Test.Tasty +import Test.HUnit +import qualified Data.Text as T +import qualified Data.ByteString.Lazy.Char8 as L (unlines) + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupBuildExe :: TestSuiteEnv -> TestTree +testGroupBuildExe env = testGroup "Build executable" $ exeTests env [ + stdTest env "From some .lhs files" test_fromLhsFiles + , stdTest env "From some .lhs files with dynamic include path change" test_fromLhsFiles_DynamicIncludePathChange + , stdTest env "Build executable from 2 TH files" test_2TH + , stdTest env "Build executable from Main" test_fromMain + , stdTest env "Build executable from Main with explicit -package" test_explicitPackage + , stdTest env "Build executable from ParFib.Main" test_ParfibMain + , stdTest env "Build executable with a wrong filename and fail" test_wrongFilename + , stdTest env "buildExe on code with type errors (#160)" test_typeErrors + ] + +-- TODO: We should mark this session as dont-reuse (there is no point) +test_fromLhsFiles :: TestSuiteEnv -> Assertion +test_fromLhsFiles env = withAvailableSession' env (withIncludes ["TestSuite/inputs/compiler/utils"]) $ \session -> do + loadModulesFrom session "TestSuite/inputs/compiler/utils" + assertNoErrors session + status0 <- getBuildExeStatus session + assertEqual "before exe build" Nothing status0 + distDir <- getDistDir session + + let m = "Maybes" + upd = buildExe [] [(T.pack m, m <.> "lhs")] + updateSessionD session upd 4 + assertNoErrors session + status1 <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status1 + let m2 = "Exception" + upd2 = buildExe [] [(T.pack m2, m2 <.> "hs")] + updateSessionD session upd2 3 + let m3 = "Main" + upd3 = buildExe [] [(T.pack m3, "Subdir" m3 <.> "lhs")] + updateSessionD session upd3 1 + out <- readProcess (distDir "build" m m) [] [] + assertEqual "Maybes exe output" + "False\n" + out + runActions1 <- runExe session m + (outExe1, statusExe1) <- runWaitAll runActions1 + assertEqual "Maybes exe output from runExe 1" + "False\n" + outExe1 + assertEqual "after runExe 1" ExitSuccess statusExe1 + + out2 <- readProcess (distDir "build" m2 m2) [] [] + assertEqual "Exception exe output" + "" + out2 + runActions2 <- runExe session m2 + (outExe2, statusExe2) <- runWaitAll runActions2 + assertEqual "Maybes exe output from runExe 2" + "" + outExe2 + assertEqual "after runExe 2" ExitSuccess statusExe2 + + out3 <- readProcess (distDir "build" m3 m3) [] [] + assertEqual "Main exe output" + "" + out3 + runActions3 <- runExe session m3 + (outExe3, statusExe3) <- runWaitAll runActions3 + assertEqual "Maybes exe output from runExe 3" + "" + outExe3 + assertEqual "after runExe 3" ExitSuccess statusExe3 + + status4 <- getBuildExeStatus session + assertEqual "after all exe builds" (Just ExitSuccess) status4 + +test_fromLhsFiles_DynamicIncludePathChange :: TestSuiteEnv -> Assertion +test_fromLhsFiles_DynamicIncludePathChange env = withAvailableSession env $ \session -> do + loadModulesFrom session "TestSuite/inputs/compiler/utils" + assertNoErrors session + let m = "Maybes" + upd0 = buildExe [] [(T.pack m, m <.> "lhs")] + updateSessionD session upd0 0 + assertNoErrors session + status0 <- getBuildExeStatus session + -- Expected failure! The updateRelativeIncludes below is really needed. + assertEqual "after exe build 1" (Just $ ExitFailure 1) status0 + updateSessionD session + (updateRelativeIncludes ["TestSuite/inputs/compiler/utils"]) + 4 + assertNoErrors session + distDir <- getDistDir session + + updateSessionD session upd0 4 + status1 <- getBuildExeStatus session + assertEqual "after exe build 2" (Just ExitSuccess) status1 + out <- readProcess (distDir "build" m m) [] [] + assertEqual "Maybes exe output" + "False\n" + out + runActions1 <- runExe session m + (outExe1, statusExe1) <- runWaitAll runActions1 + assertEqual "Maybes exe output from runExe 1" + "False\n" + outExe1 + assertEqual "after runExe 1" ExitSuccess statusExe1 + + let m2 = "Exception" + upd2 = buildExe [] [(T.pack m2, m2 <.> "hs")] + updateSessionD session upd2 1 + out2 <- readProcess (distDir "build" m2 m2) [] [] + assertEqual "Exception exe output" + "" + out2 + runActions2 <- runExe session m2 + (outExe2, statusExe2) <- runWaitAll runActions2 + assertEqual "Maybes exe output from runExe 2" + "" + outExe2 + assertEqual "after runExe 2" ExitSuccess statusExe2 + + let m3 = "Main" + upd3 = buildExe [] [(T.pack m3, "Subdir" m3 <.> "lhs")] + updateSessionD session upd3 1 + out3 <- readProcess (distDir "build" m3 m3) [] [] + assertEqual "Main exe output" + "" + out3 + runActions3 <- runExe session m3 + (outExe3, statusExe3) <- runWaitAll runActions3 + assertEqual "Maybes exe output from runExe 3" + "" + outExe3 + assertEqual "after runExe 3" ExitSuccess statusExe3 + + let upd4 = buildExe [] [(T.pack m, m <.> "lhs")] + updateSessionD session upd4 2 + status4 <- getBuildExeStatus session + assertEqual "after all exe builds" (Just ExitSuccess) status4 + +test_2TH :: TestSuiteEnv -> Assertion +test_2TH env = withAvailableSession env $ \session -> do + updateSessionD session upd 2 + assertNoErrors session + let m = "Main" + upd2 = buildExe [] [(T.pack m, "B.hs")] + updateSessionD session upd2 3 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + where + upd = updateCodeGeneration True + <> (updateSourceFile "A.hs" . L.unlines $ + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A where" + , "import Language.Haskell.TH" + , "ex1 :: Q Exp" + , "ex1 = [| \\x -> x |]" + , "ex2 :: Q Type" + , "ex2 = [t| String -> String |]" + , "ex3 :: Q [Dec]" + , "ex3 = [d| foo x = x |]" + ]) + <> (updateSourceFile "B.hs" . L.unlines $ + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module Main where" + , "import A" + -- Types and expressions + , "ex5 :: $ex2" + , "ex5 = $ex1" + -- Just to test slightly larger expressions + , "ex6 :: $(return =<< ex2)" + , "ex6 = $(ex1 >>= return)" + -- Declarations + , "$ex3" + -- Outcome + , "main :: IO ()" + , "main = print $ $ex1 42" + ]) + +test_fromMain :: TestSuiteEnv -> Assertion +test_fromMain env = withAvailableSession env $ \session -> do + withCurrentDirectory "TestSuite/inputs/MainModule" $ do + loadModulesFrom session "." + assertNoErrors session + let m = "Main" + upd = buildExe [] [(T.pack m, "ParFib.hs")] + updateSessionD session upd 3 + distDir <- getDistDir session + fibOut <- readProcess (distDir "build" m m) [] [] + assertEqual "ParFib exe output" + "running 'A single file with a code to run in parallel' from MainModule/ParFib, which says fib 24 = 75025\n" + fibOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "running 'A single file with a code to run in parallel' from MainModule/ParFib, which says fib 24 = 75025\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + +test_explicitPackage :: TestSuiteEnv -> Assertion +test_explicitPackage env = withAvailableSession' env (withGhcOpts packageOpts) $ \session -> do + withCurrentDirectory "TestSuite/inputs/MainModule" $ do + loadModulesFrom session "." + assertNoErrors session + let m = "Main" + upd = buildExe [] [(T.pack m, "ParFib.hs")] + updateSessionD session upd 3 + distDir <- getDistDir session + fibOut <- readProcess (distDir "build" m m) [] [] + assertEqual "ParFib exe output" + "running 'A single file with a code to run in parallel' from MainModule/ParFib, which says fib 24 = 75025\n" + fibOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "running 'A single file with a code to run in parallel' from MainModule/ParFib, which says fib 24 = 75025\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + packageOpts = [ "-hide-all-packages" + , "-package base" + , "-package parallel" + ] + +test_ParfibMain :: TestSuiteEnv -> Assertion +test_ParfibMain env = withAvailableSession env $ \session -> do + withCurrentDirectory "TestSuite/inputs/MainModule" $ do + loadModulesFrom session "." + assertNoErrors session + let m = "ParFib.Main" + upd = buildExe [] [ (T.pack m, "ParFib.Main.hs") + , (T.pack "Main", "ParFib.hs") ] + updateSessionD session upd 4 + assertNoErrors session + let upd2 = buildExe [] [(T.pack "Main", "ParFib.hs")] + updateSessionD session upd2 0 + distDir <- getDistDir session + fibOut <- readProcess (distDir "build" m m) [] [] + assertEqual "ParFib exe output" + "running 'A single file with a code to run in parallel' from MainModule/ParFib, which says fib 24 = 75025\n" + fibOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "running 'A single file with a code to run in parallel' from MainModule/ParFib, which says fib 24 = 75025\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + +test_wrongFilename :: TestSuiteEnv -> Assertion +test_wrongFilename env = withAvailableSession env $ \session -> do + withCurrentDirectory "TestSuite/inputs/MainModule" $ do + loadModulesFrom session "." + assertNoErrors session + let m = "Main" + upd = buildExe [] [(T.pack m, "foooooooooooooooo.hs")] + updateSessionD session upd 1 + assertNoErrors session + status1 <- getBuildExeStatus session + assertEqual "failure after exe build" (Just $ ExitFailure 1) status1 + +test_typeErrors :: TestSuiteEnv -> Assertion +test_typeErrors env = withAvailableSession env $ \session -> do + updateSessionD session upd1 1 + assertOneError session + + updateSessionD session upd2 1 + + distDir <- getDistDir session + status <- getBuildExeStatus session + assertEqual "" (Just $ ExitFailure 1) status + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "" "Source or other errors encountered. Not attempting to build executables." buildStderr + where + upd1 = (updateCodeGeneration True) + <> (updateSourceFile "Main.hs" "main = foo") + upd2 = buildExe [] [("Main", "Main.hs")] diff --git a/TestSuite/TestSuite/Tests/BuildLicenses.hs b/TestSuite/TestSuite/Tests/BuildLicenses.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/BuildLicenses.hs @@ -0,0 +1,204 @@ +module TestSuite.Tests.BuildLicenses (testGroupBuildLicenses) where + +import Data.Monoid +import Distribution.License (License (..)) +import System.Directory +import System.Exit +import System.FilePath +import Test.HUnit +import Test.Tasty +import qualified Data.Text as T + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupBuildLicenses :: TestSuiteEnv -> TestTree +testGroupBuildLicenses env = testGroup "Build licenses" [ + stdTest env "Build licenses from NamedFieldPuns without errors" test_NamedFieldPunsCorrect + , stdTest env "Build licenses from NamedFieldPuns (with errors)" test_NamedFieldPunsErrors + , stdTest env "Build licenses with wrong cabal files and fail" test_wrongCabalFile + , stdTest env "Build licenses from ParFib" test_ParFib + , stdTest env "Build licenses from Cabal" test_Cabal + , stdTest env "Build licenses from 1000 packages fixed in config with no license file" test_1000_noLicense + , stdTest env "Build licenses from 1000 packages fixed in config with no useful info" test_1000_noUsefulInfo + , stdTest env "Build licenses from TH with a wrong cabals dir and don't fail" test_TH + ] + +test_NamedFieldPunsCorrect :: TestSuiteEnv -> Assertion +test_NamedFieldPunsCorrect env = withAvailableSession' env (withGhcOpts ["-hide-package monads-tf"]) $ \session -> do + let punOpts = ["-XNamedFieldPuns", "-XRecordWildCards"] + update2 = updateGhcOpts punOpts + updateSessionD session update2 0 + loadModulesFrom session "TestSuite/inputs/Puns" + assertNoErrors session + cabalsPath <- canonicalizePath "TestSuite/inputs/Puns/cabals" + let upd = buildLicenses cabalsPath + updateSessionD session upd 99 + assertNoErrors session + distDir <- getDistDir session + licensesWarns <- readFile $ distDir "licenses.stderr" + assertEqual "licensesWarns length" 3 (length $ lines licensesWarns) + status <- getBuildLicensesStatus session + assertEqual "after license build" (Just ExitSuccess) status + licenses <- readFile $ distDir "licenses.txt" + assertBool ("licenses length (" ++ show (length licenses) ++ ")") $ length licenses >= 25000 + +test_NamedFieldPunsErrors :: TestSuiteEnv -> Assertion +test_NamedFieldPunsErrors env = withAvailableSession' env (withGhcOpts ["-hide-package monads-tf"]) $ \session -> do + loadModulesFrom session "TestSuite/inputs/Puns" + assertMoreErrors session + cabalsPath <- canonicalizePath "TestSuite/inputs/Puns/cabals" + let upd = buildLicenses cabalsPath + updateSessionD session upd 99 + assertMoreErrors session + distDir <- getDistDir session + licensesWarns <- readFile $ distDir "licenses.stderr" + assertEqual "licensesError length" 1 (length $ lines licensesWarns) + status <- getBuildLicensesStatus session + assertEqual "after license build" (Just $ ExitFailure 1) status + +test_wrongCabalFile :: TestSuiteEnv -> Assertion +test_wrongCabalFile env = withAvailableSession' env (withGhcOpts ["-hide-package monads-tf"]) $ \session -> do + loadModulesFrom session "TestSuite/inputs/Puns" + assertMoreErrors session + cabalsPath <- canonicalizePath "TestSuite/inputs/Puns/cabals/parse_error" + let updL = buildLicenses cabalsPath + punOpts = ["-XNamedFieldPuns", "-XRecordWildCards"] + upd = updL <> updateGhcOpts punOpts + updateSessionD session upd 99 + assertNoErrors session + status <- getBuildLicensesStatus session + assertEqual "after license parse_error" (Just ExitSuccess) status + distDir <- getDistDir session + licensesErr <- readFile $ distDir "licenses.stderr" + assertEqual "licensesErr length" 18 (length $ lines licensesErr) + cabalsPath2 <- canonicalizePath "TestSuite/inputs/Puns/cabals/no_text_error" + let upd2 = buildLicenses cabalsPath2 + updateSessionD session upd2 99 + status2 <- getBuildLicensesStatus session + assertEqual "after license no_text_error" (Just ExitSuccess) status2 + licensesErr2 <- readFile $ distDir "licenses.stderr" + assertEqual "licensesErr2 length" 18 (length $ lines licensesErr2) + +test_ParFib :: TestSuiteEnv -> Assertion +test_ParFib env = withAvailableSession env $ \session -> do + withCurrentDirectory "TestSuite/inputs/MainModule" $ do + loadModulesFrom session "." + assertNoErrors session + cabalsPath <- canonicalizePath "TestSuite/inputs/MainModule/cabals" + let upd = buildLicenses cabalsPath + updateSessionD session upd 6 + distDir <- getDistDir session + licensesErrs <- readFile $ distDir "licenses.stderr" + assertEqual "licensesErrs" "" licensesErrs + status <- getBuildLicensesStatus session + assertEqual "after license build" (Just ExitSuccess) status + licenses <- readFile $ distDir "licenses.txt" + assertBool ("licenses length (" ++ show (length licenses) ++ ")") $ length licenses >= 14165 + +test_Cabal :: TestSuiteEnv -> Assertion +test_Cabal env = withAvailableSession env $ \session -> do + withCurrentDirectory (testInputPathCabal env) $ do + loadModulesFrom session "." + assertNoErrors session + cabalsPath <- canonicalizePath "TestSuite/inputs/Puns/cabals" -- 7 packages missing + let upd = buildLicenses cabalsPath + updateSessionD session upd 99 + distDir <- getDistDir session + licensesErrs <- readFile $ distDir "licenses.stderr" + assertBool "licensesErrs length" $ length (lines licensesErrs) < 10 + status <- getBuildLicensesStatus session + assertEqual "after license build" (Just ExitSuccess) status + licenses <- readFile $ distDir "licenses.txt" + assertBool "licenses length" $ length licenses >= 21423 + +test_1000_noLicense :: TestSuiteEnv -> Assertion +test_1000_noLicense env = withAvailableSession env $ \session -> do + distDir <- getDistDir session + ideConfig <- getSessionConfig session + let liStdoutLog = distDir "licenses.stdout" + liStderrLog = distDir "licenses.stderr" + liArgs = + LicenseArgs{ liPackageDBStack = configPackageDBStack ideConfig + , liExtraPathDirs = configExtraPathDirs ideConfig + , liLicenseExc = configLicenseExc ideConfig + , liDistDir = distDir + , liStdoutLog + , liStderrLog + , licenseFixed = lics + , liCabalsDir = "test" + , liPkgs = pkgs + } + status <- buildLicsFromPkgs False liArgs + assertEqual "after license build" ExitSuccess status + licenses <- readFile $ distDir "licenses.txt" + assertBool "licenses length" $ length licenses >= 1527726 + where + licenseFixedConfig :: Int -> [( String + , (Maybe License, Maybe FilePath, Maybe String) + )] + licenseFixedConfig 0 = [] + licenseFixedConfig n = ("p" ++ show n, (Just BSD3, Nothing, Nothing)) + : licenseFixedConfig (n - 1) + + lics = licenseFixedConfig 1000 + pkgs = map (\(name, _) -> + PackageId{ packageName = T.pack name + , packageVersion = Just "1.0" + , packageKey = T.pack name -- ?? TODO + } + ) lics + +test_1000_noUsefulInfo :: TestSuiteEnv -> Assertion +test_1000_noUsefulInfo env = withAvailableSession env $ \session -> do + distDir <- getDistDir session + ideConfig <- getSessionConfig session + let liStdoutLog = distDir "licenses.stdout" + liStderrLog = distDir "licenses.stderr" + liArgs = + LicenseArgs{ liPackageDBStack = configPackageDBStack ideConfig + , liExtraPathDirs = configExtraPathDirs ideConfig + , liLicenseExc = configLicenseExc ideConfig + , liDistDir = distDir + , liStdoutLog + , liStderrLog + , licenseFixed = lics + , liCabalsDir = "test" + , liPkgs = pkgs + } + status <- buildLicsFromPkgs False liArgs + assertEqual "after license build" ExitSuccess status + licenses <- readFile $ distDir "licenses.txt" + assertBool "licenses length" $ length licenses >= 63619 + where + licenseFixedConfig :: Int -> [( String + , (Maybe License, Maybe FilePath, Maybe String) + )] + licenseFixedConfig 0 = [] + licenseFixedConfig n = ("p" ++ show n, (Just BSD3, Just "TestSuite/inputs/BSD_TEST", Nothing)) + : licenseFixedConfig (n - 1) + + lics = licenseFixedConfig 1000 + pkgs = map (\(name, _) -> + PackageId{ packageName = T.pack name + , packageVersion = Just "1.0" + , packageKey = T.pack name -- ?? TODO + } + ) lics + +test_TH :: TestSuiteEnv -> Assertion +test_TH env = withAvailableSession' env (withGhcOpts ["-XTemplateHaskell"]) $ \session -> do + withCurrentDirectory "TestSuite/inputs" $ do + (originalUpdate, lm) <- getModulesFrom "TH" + let update = originalUpdate <> updateCodeGeneration True + updateSessionD session update (length lm) + assertNoErrors session + let upd = buildLicenses "--/fooo /fooo/foo" + updateSessionD session upd 99 + distDir <- getDistDir session + licensesErrs <- readFile $ distDir "licenses.stderr" + assertBool "licensesErrs length" $ length licensesErrs > 0 + status <- getBuildLicensesStatus session + assertEqual "after license build" (Just ExitSuccess) status diff --git a/TestSuite/TestSuite/Tests/C.hs b/TestSuite/TestSuite/Tests/C.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/C.hs @@ -0,0 +1,473 @@ +module TestSuite.Tests.C (testGroupC) where + +import Control.Monad +import Data.List (intercalate) +import Data.Monoid +import System.Exit +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L (unlines) +import qualified Data.Text as T + +import IdeSession +import TestSuite.Assertions +import TestSuite.Session +import TestSuite.State + +testGroupC :: TestSuiteEnv -> TestTree +testGroupC env = testGroup "Using C files" [ + stdTest env "Basic functionality, recompiling Haskell modules when necessary" test_Basic + , stdTest env "C files in subdirs" test_subdirs + , stdTest env "Errors and warnings in the C code" test_errors + , stdTest env "Errors in C file, then update C file (#201)" test_errorsThenUpdate + , stdTest env "C header files in subdirectories (#212)" test_headersInSubdirs + , stdTest env "C code writes to stdout (#210)" test_stdout + , stdTest env "Deleting C file should unload object file (#241)" test241 + , testGroup "Two C files (no cyclic dependencies)" $ test_2 env + , testGroup "Two C files (C files mutually dependent)" $ test_2_cyclic env + ] + +test_Basic :: TestSuiteEnv -> Assertion +test_Basic env = withAvailableSession env $ \session -> do + -- TODO: Ideally, we'd fix this jump in the reported total number of + -- progress messages + updateSessionP session upd [ + (1, 1, "Compiling MC.c") + , (2, 2, "Compiling M") + ] + assertNoErrors session + do runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "12345\n" output + + ifTestingExe env $ do + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "12345\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + + -- Update the Haskell module without updating the C module + updateSessionP session upd2 [ + (1, 1, "Compiling M") + ] + assertNoErrors session + do runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "12346\n" output + + ifTestingExe env $ do + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "12346\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + + -- Update the C code without updating the Haskell module + updateSessionP session upd3 [ + (1, 1, "Compiling MC.c") + , (2, 2, "Compiling M") + ] + assertNoErrors session + do runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "54322\n" output + + ifTestingExe env $ do + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 3 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "54322\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Foreign.C" + , "foreign import ccall \"foo\" c_f :: CInt" + , "hello :: IO ()" + , "hello = print c_f" + , "main :: IO ()" + , "main = hello" + ]) + <> (updateSourceFile "MC.c" . L.unlines $ + [ "int foo() {" + , " return 12345;" + , "}" + ]) + + upd2 = (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Foreign.C" + , "foreign import ccall \"foo\" c_f :: CInt" + , "hello :: IO ()" + , "hello = print (c_f + 1)" + , "main :: IO ()" + , "main = hello" + ]) + + upd3 = (updateSourceFile "MC.c" . L.unlines $ + [ "int foo() {" + , " return 54321;" + , "}" + ]) + +test_subdirs :: TestSuiteEnv -> Assertion +test_subdirs env = withAvailableSession env $ \session -> do + updateSessionP session upd [ + (1, 2, "Compiling a/MC.c") + , (2, 2, "Compiling b/MC.c") + , (3, 3, "Compiling M") + ] + assertNoErrors session + do runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "79\n" output + + ifTestingExe env $ do + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "79\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Foreign.C" + , "foreign import ccall \"foo\" c_f :: CInt" + , "foreign import ccall \"bar\" c_g :: CInt" + , "hello :: IO ()" + , "hello = print (c_f + c_g)" + , "main :: IO ()" + , "main = hello" + ]) + <> (updateSourceFile "a/MC.c" . L.unlines $ + [ "int foo() {" + , " return 56;" + , "}" + ]) + -- intentionally same name for the file + <> (updateSourceFile "b/MC.c" . L.unlines $ + [ "int bar() {" + , " return 23;" + , "}" + ]) + +test_errors :: TestSuiteEnv -> Assertion +test_errors env = withAvailableSession env $ \session -> do + updateSessionP session upd [ + (1, 1, "Compiling MC.c") + , (2, 2, "Compiling M") + ] + errors <- getSourceErrors session + case errors of + [e1, e2] -> do + -- Currently we generate precisely one gcc error + assertEqual "" (TextSpan (T.pack "")) (errorSpan e1) + -- The ByteCodeLink exception because of the missing symbol + assertEqual "" (TextSpan (T.pack "")) (errorSpan e2) + _ -> assertFailure $ "Unexpected errors: " ++ show errors + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Foreign.C" + , "foreign import ccall \"foo\" c_f :: CInt" + , "hello :: IO ()" + , "hello = print c_f" + ]) + <> (updateSourceFile "MC.c" . L.unlines $ [ + "int f() {" + , " return thisSymbolDoesNotExist;" + , "}" + , "" + , "void g() {" + , " return 1;" + , "}" + ]) + +test_errorsThenUpdate :: TestSuiteEnv -> Assertion +test_errorsThenUpdate env = withAvailableSession env $ \session -> do + updateSessionD session upd 3 + assertNoErrors session + + runActions <- runStmt session "Main" "main" + (output, result) <- runWaitAll runActions + assertEqual "" result RunOk + assertEqual "" output "42\n" + + updateSessionD session (updateSourceFile "test.c" "invalid") 3 + assertSomeErrors session + + updateSessionD session (updateSourceFile "test.c" cLBS) 3 + assertNoErrors session + where + mainLBS = L.unlines $ [ + "import Foreign" + , "import Foreign.C" + , "import Foreign.C.Types" + , "foreign import ccall safe \"test_c_func\" test_c_func :: CInt" + , "main = print test_c_func" + ] + cLBS = L.unlines $ [ + "int test_c_func() { return 42; }" + ] + + upd = updateCodeGeneration True + <> updateSourceFile "Main.hs" mainLBS + <> updateSourceFile "test.c" cLBS + +test_headersInSubdirs :: TestSuiteEnv -> Assertion +test_headersInSubdirs env = withAvailableSession' env (withIncludes ["include"]) $ \session -> do + let go upd = do + updateSessionD session upd 3 + assertNoErrors session + + go $ updateGhcOpts ["-Iinclude"] + <> updateSourceFile "include/blankheader.h" hfile + <> updateSourceFile "hello.c" cfile + <> updateSourceFile "Main.hs" hsfile + where + hfile = "#define foo \"hello\\n\"" + cfile = L.unlines $ + [ "#include " + , "#include " + , "void hello(void) { printf(foo); }" + ] + hsfile = L.unlines $ + [ "{-# LANGUAGE ForeignFunctionInterface #-}" + , "module Main where" + , "foreign import ccall \"hello\" hello :: IO ()" + , "main = hello" + ] + +test_stdout :: TestSuiteEnv -> Assertion +test_stdout env = withAvailableSession env $ \session -> do + updateSessionD session upd 3 + assertNoErrors session + + ra <- runStmt session "Main" "main" + (output, result) <- runWaitAll ra + assertEqual "" result RunOk + assertEqual "" output "hello\n" + where + cfile = L.unlines $ + [ "#include " + , "void hello(void) { printf(\"hello\\n\"); }" + ] + hsfile = L.unlines $ + [ "{-# LANGUAGE ForeignFunctionInterface #-}" + , "module Main where" + , "import System.IO" + , "foreign import ccall \"hello\" hello :: IO ()" + , "main = hello" + ] + + upd = updateCodeGeneration True + <> updateSourceFile "hello.c" cfile + <> updateSourceFile "Main.hs" hsfile + +test241 :: TestSuiteEnv -> Assertion +test241 env = withAvailableSession env $ \session -> do + updateSessionP session (updateCodeGeneration True <> updHs <> updC "a.c") [ + (1, 1, "Compiling a.c") + , (2, 2, "Compiling M") + ] + assertNoErrors session + do runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "12345\n" output + + updateSessionD session (updateSourceFileDelete "a.c") 0 + + updateSessionP session (updC "b.c") [ + (1, 1, "Compiling b.c") + , (2, 2, "Compiling M") + ] + assertNoErrors session + do runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "12345\n" output + where + updHs = updateSourceFile "M.hs" . L.unlines $ [ + "module M where" + , "import Foreign.C" + , "foreign import ccall \"foo\" c_f :: CInt" + , "hello :: IO ()" + , "hello = print c_f" + , "main :: IO ()" + , "main = hello" + ] + updC f = updateSourceFile f . L.unlines $ [ + "int foo() {" + , " return 12345;" + , "}" + ] + +{------------------------------------------------------------------------------- + Stress tests about the order of object loading +-------------------------------------------------------------------------------} + +test_2 :: TestSuiteEnv -> [TestTree] +test_2 = \env -> + [ stdTest env (describeSchedule s) (testSchedule s) + | s <- schedule updates + ] + where + updates :: [(String, IdeSessionUpdate)] + updates = [ + ( "Load a.c", updateSourceFile "a.c" cfileA) + , ( "Load b.c", updateSourceFile "b.c" cfileB) + , ( "Load .hs", updateSourceFile "Main.hs" hsfile) + ] + + cfileA, cfileB, hsfile :: L.ByteString + cfileA = L.unlines $ + [ "#include " + , "void defined_in_A() {" + , " printf(\"In A\\n\");" + , "}" + ] + cfileB = L.unlines $ + [ "#include " + , "" + , "void defined_in_A();" + , "" + , "void defined_in_B() {" + , " printf(\"In B\\n\");" + , " defined_in_A();" + , " printf(\"In B\\n\");" + , "}" + ] + hsfile = L.unlines $ + [ "{-# LANGUAGE ForeignFunctionInterface #-}" + , "module Main where" + , "import System.IO" + , "foreign import ccall \"defined_in_B\" defined_in_B :: IO ()" + , "main = defined_in_B" + ] + +test_2_cyclic :: TestSuiteEnv -> [TestTree] +test_2_cyclic = \env -> + [ stdTest env (describeSchedule s) (testSchedule s) + | s <- schedule updates + ] + where + updates :: [(String, IdeSessionUpdate)] + updates = [ + ( "Load a.c", updateSourceFile "a.c" cfileA) + , ( "Load b.c", updateSourceFile "b.c" cfileB) + , ( "Load .hs", updateSourceFile "Main.hs" hsfile) + ] + + cfileA, cfileB, hsfile :: L.ByteString + cfileA = L.unlines $ + [ "#include " + , "" + , "void also_defined_in_B();" + , "" + , "void defined_in_A() {" + , " printf(\"In A\\n\");" + , " also_defined_in_B();" + , "}" + ] + cfileB = L.unlines $ + [ "#include " + , "" + , "void defined_in_A();" + , "" + , "void defined_in_B() {" + , " printf(\"In B\\n\");" + , " defined_in_A();" + , "}" + , "" + , "void also_defined_in_B() {" + , " printf(\"In B\\n\");" + , "}" + ] + hsfile = L.unlines $ + [ "{-# LANGUAGE ForeignFunctionInterface #-}" + , "module Main where" + , "import System.IO" + , "foreign import ccall \"defined_in_B\" defined_in_B :: IO ()" + , "main = defined_in_B" + ] + +describeSchedule :: Schedule (String, IdeSessionUpdate) -> String +describeSchedule = intercalate "; " + . map (bracket . intercalate ", ") + . map (map fst) + +testSchedule :: Schedule (String, IdeSessionUpdate) -> TestSuiteEnv -> Assertion +testSchedule s env = withAvailableSession env $ \session -> do + -- Enable code generation + updateSessionD session (updateCodeGeneration True) 0 + + -- Execute each task in the schedule + -- (this may have errors until the very last one) + forM_ s $ \ts -> updateSessionD session (mconcat (map snd ts)) 3 + + -- But after the last one there should be no more errors + assertNoErrors session + + -- Run the code + ra <- runStmt session "Main" "main" + (output, result) <- runWaitAll ra + assertEqual "" result RunOk + assertEqual "" output "In B\nIn A\nIn B\n" + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +bracket :: String -> String +bracket s = "[" ++ s ++ "]" + +-- | Execute a bunch of tasks sequentially +type Schedule a = [Task a] + +-- | Execute a bunch of operations concurrently (must be non-empty) +type Task a = [a] + +schedule :: [a] -> [Schedule a] +schedule [] = [[]] +schedule (a:as) = let ss = schedule as + in concat $ map (insertSomewhere [a]) ss + ++ map (applySomewhere (a:)) ss + +-- | Apply a function to precisely one element in the list +applySomewhere :: (a -> a) -> [a] -> [[a]] +applySomewhere f = expandOne (return . f) + +-- | Insert an element somewhere in the list +insertSomewhere :: a -> [a] -> [[a]] +insertSomewhere x xs = (x:xs) : expandOne (: [x]) xs + +-- | Apply 'f' to precisely one element +expandOne :: (a -> [a]) -> [a] -> [[a]] +expandOne _ [] = [] +expandOne f (x:xs) = (f x ++ xs) : map (x :) (expandOne f xs) diff --git a/TestSuite/TestSuite/Tests/CabalMacros.hs b/TestSuite/TestSuite/Tests/CabalMacros.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/CabalMacros.hs @@ -0,0 +1,251 @@ +module TestSuite.Tests.CabalMacros (testGroupCabalMacros) where + +import Control.Exception +import Data.Monoid +import System.Exit +import System.FilePath +import System.Process +import Test.HUnit +import Test.Tasty +import qualified Data.ByteString.Lazy.Char8 as L (unlines) +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupCabalMacros :: TestSuiteEnv -> TestTree +testGroupCabalMacros env = testGroup "Cabal macros" [ + stdTest env "Use cabal macro MIN_VERSION for a package we really depend on" test_MinVersionForDependency + , stdTest env "Use cabal macro MIN_VERSION for a package we don't really depend on" test_MinVersionForNonDependency + , stdTest env "Use cabal macro VERSION by checking if defined" test_checkCabalMacroDefined + , stdTest env "Use cabal macro VERSION by including an external macros file" test_includeExternalMacros + , stdTest env "Caching cabal macros" test_caching + ] + +test_MinVersionForDependency :: TestSuiteEnv -> Assertion +test_MinVersionForDependency env = withAvailableSession' env (withGhcOpts ["-XCPP"]) $ \session -> do + macros <- getCabalMacros session + assertBool "Main with cabal macro exe output" (not $ L.null macros) + -- assertEqual "Main with cabal macro exe output" (BSLC.pack "") macros + updateSessionD session update 1 + assertNoErrors session + let update2 = updateCodeGeneration True + updateSessionD session update2 1 + assertNoErrors session + + do runActions <- runStmt session "Main" "main" + (output, _) <- runWaitAll runActions + assertEqual "result of ifdefed print 5" "5\n" output + + ifTestingExe env $ do + let m = "Main" + upd = buildExe [] [(T.pack m, "Main.hs")] + updateSessionD session upd 2 + distDir <- getDistDir session + mOut <- readProcess (distDir "build" m m) [] [] + assertEqual "Main with cabal macro exe output" "5\n" mOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "5\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + update = updateSourceFile "Main.hs" $ L.unlines + [ "#if !MIN_VERSION_base(999,0,0)" + , "main = print 5" + , "#else" + , "terrible error" + , "#endif" + ] + +test_MinVersionForNonDependency :: TestSuiteEnv -> Assertion +test_MinVersionForNonDependency env = withAvailableSession' env (withGhcOpts ["-XCPP"]) $ \session -> do + updateSessionD session update 1 + assertNoErrors session + let update2 = updateCodeGeneration True + updateSessionD session update2 1 + assertNoErrors session + runActions <- runStmt session "Main" "main" + (output, _) <- runWaitAll runActions + assertEqual "result of ifdefed print 5" "5\n" output + +{- FIXME + let m = "Main" + upd = buildExe [] [(Text.pack m, "Main.hs")] + updateSessionD session upd 2 + assertNoErrors session + distDir <- getDistDir session + mOut <- readProcess (distDir "build" m m) [] [] + assertEqual "Main with cabal macro exe output" "5\n" mOut + + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "5\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + -} + where + update = updateSourceFile "Main.hs" $ L.unlines + [ "#if !MIN_VERSION_containers(999,0,0)" + , "main = print 5" + , "#else" + , "terrible error" + , "#endif" + ] + +test_checkCabalMacroDefined :: TestSuiteEnv -> Assertion +test_checkCabalMacroDefined env = withAvailableSession' env (withGhcOpts ["-XCPP"]) $ \session -> do + macros <- getCabalMacros session + assertBool "M with cabal macro exe output" (not $ L.null macros) + updateSessionD session (update <> updateCodeGeneration True) 1 + assertNoErrors session + + do runActions <- runStmt session "M" "main" + (output, _) <- runWaitAll runActions + assertEqual "result of ifdefed print 5" "5\n" output + + ifTestingExe env $ do + let m = "M" + upd = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session upd 2 + distDir <- getDistDir session + mOut <- readProcess (distDir "build" m m) [] [] + assertEqual "M with cabal macro exe output" "5\n" mOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "5\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + update = updateSourceFile "M.hs" $ L.unlines + [ "module M where" + , "#ifdef VERSION_base" + , "" + , "#if defined(VERSION_base)" + , "main = print 5" + , "#else" + , "terrible error" + , "#endif" + , "" + , "#else" + , "terrible error 2" + , "#endif" + ] + +test_includeExternalMacros :: TestSuiteEnv -> Assertion +test_includeExternalMacros env = withAvailableSession' env (withGhcOpts ["-XCPP"]) $ \session -> do + macros <- getCabalMacros session + assertBool "M with cabal macro exe output" (not $ L.null macros) + updateSessionD session (update <> updateCodeGeneration True) 1 + assertNoErrors session + + do runActions <- runStmt session "M" "main" + (output, _) <- runWaitAll runActions + assertEqual "result of ifdefed print 5" "False\n" output + + ifTestingExe env $ do + let m = "M" + upd = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session upd 2 + distDir <- getDistDir session + mOut <- readProcess (distDir "build" m m) [] [] + assertEqual "M with cabal macro exe output" "False\n" mOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "False\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + update = updateSourceFile "M.hs" (L.unlines + [ "module M where" + , "#include \"cabal_macros.h\"" + , "main = print $ MY_VERSION_base == \"foo\"" + ]) + <> updateSourceFile "cabal_macros.h" (L.unlines + [ "#define MY_VERSION_base \"4.5.1.0\"" + ]) + + +test_caching :: TestSuiteEnv -> Assertion +test_caching env = do + -- Get macros from standard session + macros <- withSession (defaultServerConfig env) getCabalMacros + + -- Initialize new session with these macros + do let cfg = (defaultServerConfig env) { + testSuiteServerCabalMacros = Just macros + } + withSession cfg $ \session -> do + let update = (updateCodeGeneration True) + <> (updateGhcOpts ["-XCPP"]) + <> (updateSourceFile "Main.hs" $ L.unlines [ + "#if !MIN_VERSION_base(999,0,0)" + , "main = print 5" + , "#else" + , "terrible error" + , "#endif" + ]) + updateSessionD session update 1 + assertNoErrors session + + do runActions <- runStmt session "Main" "main" + (output, _) <- runWaitAll runActions + assertEqual "result of ifdefed print 5" "5\n" output + + ifTestingExe env $ do + let m = "Main" + updExe = buildExe [] [(T.pack m, "Main.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "5\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + + -- Test custom macros + do let customMacros = "#define HELLO 1" + cfg = (defaultServerConfig env) { + testSuiteServerCabalMacros = Just customMacros + } + withSession cfg $ \session -> do + let update = (updateCodeGeneration True) + <> (updateGhcOpts ["-XCPP"]) + <> (updateSourceFile "Main.hs" $ L.unlines [ + "#if HELLO" + , "main = print 6" + , "#else" + , "main = print 7" + , "#endif" + ]) + updateSessionD session update 1 + assertNoErrors session + + do runActions <- runStmt session "Main" "main" + (output, _) <- runWaitAll runActions + assertEqual "result of ifdefed print 6" "6\n" output + + ifTestingExe env $ do + let m = "Main" + updExe = buildExe [] [(T.pack m, "Main.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "7\n" -- FIXME + outExe + assertEqual "after runExe" ExitSuccess statusExe + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +withSession :: TestSuiteServerConfig -> (IdeSession -> IO a) -> IO a +withSession cfg = bracket (startNewSession cfg) shutdownSession diff --git a/TestSuite/TestSuite/Tests/Compilation.hs b/TestSuite/TestSuite/Tests/Compilation.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/Compilation.hs @@ -0,0 +1,565 @@ +module TestSuite.Tests.Compilation (testGroupCompilation) where + +import Control.Monad +import Data.IORef +import Data.Monoid +import System.Exit +import System.FilePath +import System.Process +import Test.HUnit +import Test.Tasty +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.ByteString.Lazy.Char8 as L (unlines) +import qualified Data.Text as T + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupCompilation :: TestSuiteEnv -> TestTree +testGroupCompilation env = testGroup "Compilation" [ + stdTest env "Compile a project: A depends on B, error in A" test_AdependsB_errorA + , stdTest env "Compile a project: A depends on B, error in B" test_AdependsB_errorB + , stdTest env "Compile and run a project with some .lhs files" test_lhs + , stdTest env "Test recursive modules" test_recursiveModules + , stdTest env "Test recursive modules with dynamic include path change" test_dynamicIncludePathChange + , stdTest env "Test CPP: ifdefed module header" test_CPP_ifdefModuleHeader + , stdTest env "Reject a wrong CPP directive" test_rejectWrongCPP + , stdTest env "Reject a program requiring -XNamedFieldPuns, then set the option" test_NamedFieldPuns + , stdTest env "Don't recompile unnecessarily (single module)" test_DontRecompile_SingleModule + , stdTest env "Don't recompile unnecessarily (A depends on B)" test_DontRecompile_Depends + , stdTest env "Support for hs-boot files (#155)" test_HsBoot + , stdTest env "Support for lhs-boot files (#155)" test_LhsBoot + , stdTest env "Support for hs-boot files from a subdirectory (#177)" test_HsBoot_SubDir + , stdTest env "Support for hs-boot files from a subdirectory (#177) with dynamic include path change" test_HsBoot_SubDir_InclPathChange + , stdTest env "Relative include paths (#156)" test_RelInclPath + , stdTest env "Relative include paths (#156) with dynamic include path change" test_RelInclPath_InclPathChange + , stdTest env "Parse ghc 'Compiling' messages" test_ParseCompiling + , stdTest env "Parse ghc 'Compiling' messages (with TH)" test_ParseCompiling_TH + , stdTest env "Reject a module with mangled header" test_RejectMangledHeader + ] + +test_AdependsB_errorA :: TestSuiteEnv -> Assertion +test_AdependsB_errorA env = withAvailableSession env $ \session -> do + loadModulesFrom session "TestSuite/inputs/AerrorB" + assertSourceErrors session [[(Just "A.hs", "No instance for (Num (IO ()))")]] + +test_AdependsB_errorB :: TestSuiteEnv -> Assertion +test_AdependsB_errorB env = withAvailableSession env $ \session -> do + loadModulesFrom session "TestSuite/inputs/ABerror" + assertSourceErrors session [[(Just "B.hs", "No instance for (Num (IO ()))")]] + +test_lhs :: TestSuiteEnv -> Assertion +test_lhs env = withAvailableSession env $ \session -> do + loadModulesFrom session "TestSuite/inputs/compiler/utils" + assertNoErrors session + let update2 = updateCodeGeneration True + updateSessionD session update2 4 + assertNoErrors session + runActions <- runStmt session "Maybes" "main" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" output "False\n" + +test_recursiveModules :: TestSuiteEnv -> Assertion +test_recursiveModules env = withAvailableSession' env (withIncludes ["TestSuite/inputs/bootMods"]) $ \session -> do + loadModulesFrom session "TestSuite/inputs/bootMods" + assertNoErrors session + + ifTestingExe env $ do + let m = "Main" + upd = buildExe [] [(T.pack m, "C" <.> "hs")] + updateSessionD session upd 7 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + out <- readProcess (distDir "build" m m) [] [] + assertEqual "" "C\n" out + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "C\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + +test_dynamicIncludePathChange :: TestSuiteEnv -> Assertion +test_dynamicIncludePathChange env = withAvailableSession env $ \session -> do + loadModulesFrom session "TestSuite/inputs/bootMods" + assertOneError session + + updateSessionD session + (updateRelativeIncludes ["TestSuite/inputs/bootMods"]) + 4 + assertNoErrors session + + ifTestingExe env $ do + let m = "Main" + upd = buildExe [] [(T.pack m, "C" <.> "hs")] + updateSessionD session upd 7 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + out <- readProcess (distDir "build" m m) [] [] + assertEqual "" "C\n" out + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "C\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + +test_CPP_ifdefModuleHeader :: TestSuiteEnv -> Assertion +test_CPP_ifdefModuleHeader env = withAvailableSession' env (withGhcOpts ["-XCPP"]) $ \session -> do + updateSessionD session update 1 + assertNoErrors session + assertIdInfo session "Good" (8,1,8,2) "x" VarName "[a]" "main:Good" "Good.hs@8:1-8:2" "" "binding occurrence" + where + update = updateSourceFile "Good.hs" $ L.unlines + [ "#if __GLASGOW_HASKELL__ < 600" + , "module Bad where" + , "import Data.List" + , "#else" + , "module Good where" + , "import Data.Monoid" + , "#endif" + , "x = mappend [] []" + ] + +test_rejectWrongCPP :: TestSuiteEnv -> Assertion +test_rejectWrongCPP env = withAvailableSession' env (withGhcOpts ["-XCPP"]) $ \session -> do + updateSessionD session update 1 + -- Due to a GHC bug there are now 2 errors. TODO; when it's fixed, + -- assert a single specific error here. + assertSomeErrors session + assertRaises "runStmt session Main main" + (== userError "Module \"Main\" not successfully loaded, when trying to run code.") + (runStmt session "Main" "main") + where + update = loadModule "M.hs" "#ifdef" + <> updateCodeGeneration True + + +test_NamedFieldPuns :: TestSuiteEnv -> Assertion +test_NamedFieldPuns env = withAvailableSession' env (withGhcOpts ["-hide-package monads-tf"]) $ \session -> do + withCurrentDirectory "TestSuite/inputs/Puns" $ do + loadModulesFrom session "." + assertMoreErrors session + let punOpts = ["-XNamedFieldPuns", "-XRecordWildCards"] + update2 = updateGhcOpts punOpts + (_, lm) <- getModules session + updateSessionD session update2 (length lm) + assertNoErrors session + + ifTestingExe env $ do + let m = "GHC.RTS.Events" + upd2 = buildExe [] [(T.pack m, "GHC/RTS/Events.hs")] + updateSessionD session upd2 4 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + +test_DontRecompile_SingleModule :: TestSuiteEnv -> Assertion +test_DontRecompile_SingleModule env = withAvailableSession env $ \session -> do + counter <- newCounter + + updateSession session upd (\_ -> incCounter counter) + assertCounter counter 1 + + resetCounter counter + updateSession session upd (\_ -> incCounter counter) + assertCounter counter 0 + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "a :: IO ()" + , "a = print 'a'" + ]) + +test_DontRecompile_Depends :: TestSuiteEnv -> Assertion +test_DontRecompile_Depends env = withAvailableSession env $ \session -> do + counter <- newCounter + + -- Initial compilation needs to recompile for A and B + updateSession session upd (\_ -> incCounter counter) + assertCounter counter 2 + + -- Overwriting B with the same code requires no compilation at all + resetCounter counter + updateSession session (updB 0) (\_ -> incCounter counter) + assertCounter counter 0 + + -- Nor does overwriting A with the same code + resetCounter counter + updateSession session (updA 0) (\_ -> incCounter counter) + assertCounter counter 0 + + -- Giving B a new interface means both A and B need to be recompiled + resetCounter counter + updateSession session (updB 1) (\_ -> incCounter counter) + assertCounter counter 2 + + -- Changing the interface of A only requires recompilation of A + resetCounter counter + updateSession session (updA 1) (\_ -> incCounter counter) + assertCounter counter 1 + where + -- 'updA' is defined so that the interface of 'updA n' is different + -- to the interface of 'updA m' (with n /= m) + updA n = updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "import B" + ] + ++ + [ L.fromString $ "a" ++ show i ++ " = b" ++ show i + | i <- [0 .. n :: Int] + ] + updB n = updateSourceFile "B.hs" . L.unlines $ + [ "module B where" + ] + ++ + [ L.fromString $ "b" ++ show i ++ " = return () :: IO ()" + | i <- [0 .. n :: Int] + ] + upd = updateCodeGeneration True <> updA 0 <> updB 0 + +test_HsBoot :: TestSuiteEnv -> Assertion +test_HsBoot env = withAvailableSession env $ \session -> do + updateSessionD session upd 3 + assertNoErrors session + + ifTestingExe env $ do + let m = "A" + updE = buildExe ["-rtsopts", "-O1"] [(T.pack m, m <.> "hs")] + updateSessionD session updE 4 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + out <- readProcess (distDir "build" m m) + ["+RTS", "-C0.005", "-RTS"] [] + assertEqual "" "[1,1,2,3,5,8,13,21,34,55]\n" out + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "[1,1,2,3,5,8,13,21,34,55]\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "A.hs" $ L.unlines [ + "module A where" + + , "import {-# SOURCE #-} B" + + , "f :: Int -> Int" + , "f 0 = 1" + , "f 1 = 1" + , "f n = g (n - 1) + g (n - 2)" + + , "main :: IO ()" + , "main = print $ map f [0..9]" + ]) + <> (updateSourceFile "B.hs" $ L.unlines [ + "module B where" + + , "import A" + + , "g :: Int -> Int" + , "g = f" + ]) + <> (updateSourceFile "B.hs-boot" $ L.unlines [ + "module B where" + + , "g :: Int -> Int" + ]) + +test_LhsBoot :: TestSuiteEnv -> Assertion +test_LhsBoot env = withAvailableSession env $ \session -> do + updateSessionD session upd 3 + assertNoErrors session + + ifTestingExe env $ do + let m = "A" + updE = buildExe [] [(T.pack m, m <.> "lhs")] + updateSessionD session updE 5 -- TODO: Main may be compiled twice (#189) + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + out <- readProcess (distDir "build" m m) [] [] + assertEqual "" "[1,1,2,3,5,8,13,21,34,55]\n" out + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "[1,1,2,3,5,8,13,21,34,55]\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "A.lhs" $ L.unlines [ + "> module A where" + + , "> import {-# SOURCE #-} B" + + , "> f :: Int -> Int" + , "> f 0 = 1" + , "> f 1 = 1" + , "> f n = g (n - 1) + g (n - 2)" + + , "> main :: IO ()" + , "> main = print $ map f [0..9]" + ]) + <> (updateSourceFile "B.lhs" $ L.unlines [ + "> module B where" + + , "> import A" + + , "> g :: Int -> Int" + , "> g = f" + ]) + <> (updateSourceFile "B.lhs-boot" $ L.unlines [ + "> module B where" + + , "> g :: Int -> Int" + ]) + +test_HsBoot_SubDir :: TestSuiteEnv -> Assertion +test_HsBoot_SubDir env = withAvailableSession' env (withIncludes ["src"]) $ \session -> do + updateSessionD session update 3 + assertNoErrors session + + ifTestingExe env $ do + let m = "B" + updE = buildExe [] [(T.pack m, m <.> "hs")] + updateSessionD session updE 4 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + out <- readProcess (distDir "build" m m) [] [] + assertEqual "" "42\n" out + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "42\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + ahs = "module A where\nimport B( TB(..) )\nnewtype TA = MkTA Int\nf :: TB -> TA\nf (MkTB x) = MkTA x" + ahsboot = "module A where\nnewtype TA = MkTA Int" + bhs = "module B where\nimport {-# SOURCE #-} A( TA(..) )\ndata TB = MkTB !Int\ng :: TA -> TB\ng (MkTA x) = MkTB x\nmain = print 42" + + update = updateSourceFile "src/A.hs" ahs + <> updateSourceFile "src/A.hs-boot" ahsboot + <> updateSourceFile "src/B.hs" bhs + <> updateCodeGeneration True + +test_HsBoot_SubDir_InclPathChange :: TestSuiteEnv -> Assertion +test_HsBoot_SubDir_InclPathChange env = withAvailableSession env $ \session -> do + updateSessionD session update 3 + assertOneError session + + updateSessionD session + (updateRelativeIncludes ["src"]) + 3 + assertNoErrors session + + ifTestingExe env $ do + let m = "B" + updE = buildExe [] [(T.pack m, m <.> "hs")] + updateSessionD session updE 4 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + out <- readProcess (distDir "build" m m) [] [] + assertEqual "" "42\n" out + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "42\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + ahs = "module A where\nimport B( TB(..) )\nnewtype TA = MkTA Int\nf :: TB -> TA\nf (MkTB x) = MkTA x" + ahsboot = "module A where\nnewtype TA = MkTA Int" + bhs = "module B where\nimport {-# SOURCE #-} A( TA(..) )\ndata TB = MkTB !Int\ng :: TA -> TB\ng (MkTA x) = MkTB x\nmain = print 42" + + update = updateSourceFile "src/A.hs" ahs + <> updateSourceFile "src/A.hs-boot" ahsboot + <> updateSourceFile "src/B.hs" bhs + <> updateCodeGeneration True + +test_RelInclPath :: TestSuiteEnv -> Assertion +test_RelInclPath env = withAvailableSession' env (withIncludes ["TestSuite/inputs/ABnoError"]) $ \session -> do + -- Since we set the target explicitly, ghc will need to be able to find + -- the other module (B) on its own; that means it will need an include + -- path to /TestSuite/inputs/ABnoError + loadModulesFrom' session "TestSuite/inputs/ABnoError" (TargetsInclude ["TestSuite/inputs/ABnoError/A.hs"]) + assertNoErrors session + + ifTestingExe env $ do + let updE = buildExe [] [(T.pack "Main", "TestSuite/inputs/ABnoError/A.hs")] + updateSessionD session updE 3 + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + + let updE2 = buildExe [] [(T.pack "Main", "A.hs")] + updateSessionD session updE2 0 + status2 <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status2 + +test_RelInclPath_InclPathChange :: TestSuiteEnv -> Assertion +test_RelInclPath_InclPathChange env = withAvailableSession env $ \session -> do + -- Since we set the target explicitly, ghc will need to be able to find + -- the other module (B) on its own; that means it will need an include + -- path to /TestSuite/inputs/ABnoError + loadModulesFrom' session "TestSuite/inputs/ABnoError" (TargetsInclude ["TestSuite/inputs/ABnoError/A.hs"]) + assertOneError session + + updateSessionD session + (updateRelativeIncludes ["TestSuite/inputs/ABnoError"]) + 2 -- note the recompilation + assertNoErrors session + + ifTestingExe env $ do + let updE = buildExe [] [(T.pack "Main", "TestSuite/inputs/ABnoError/A.hs")] + updateSessionD session updE 1 + status <- getBuildExeStatus session + -- Path "" no longer in include paths here! + assertEqual "after exe build" (Just $ ExitFailure 1) status + + let updE2 = buildExe [] [(T.pack "Main", "A.hs")] + updateSessionD session updE2 2 + status2 <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status2 + +test_ParseCompiling :: TestSuiteEnv -> Assertion +test_ParseCompiling env = withAvailableSession env $ \session -> do + progressUpdatesRef <- newIORef [] + updateSession session upd $ \p -> do + progressUpdates <- readIORef progressUpdatesRef + writeIORef progressUpdatesRef (progressUpdates ++ [p]) + assertNoErrors session + + progressUpdates <- readIORef progressUpdatesRef + assertEqual "" [(1, 2, Just "Compiling A"), (2, 2, Just "Compiling B")] + (map abstract progressUpdates) + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "printA :: IO ()" + , "printA = putStr \"A\"" + ]) + <> (updateSourceFile "B.hs" . L.unlines $ + [ "module B where" + , "import A" + , "printAB :: IO ()" + , "printAB = printA >> putStr \"B\"" + ]) + + abstract (Progress {..}) = ( progressStep + , progressNumSteps + , T.unpack `liftM` progressParsedMsg + ) + +test_ParseCompiling_TH :: TestSuiteEnv -> Assertion +test_ParseCompiling_TH env = withAvailableSession env $ \session -> do + progressUpdatesRef <- newIORef [] + updateSession session upd $ \p -> do + progressUpdates <- readIORef progressUpdatesRef + writeIORef progressUpdatesRef (progressUpdates ++ [p]) + assertNoErrors session + + do progressUpdates <- readIORef progressUpdatesRef + assertEqual "" [(1, 2, Just "Compiling A"), (2, 2, Just "Compiling Main")] + (map abstract progressUpdates) + + -- Now we touch A, triggering recompilation of both A and B + -- This will cause ghc to report "[TH]" as part of the progress message + -- (at least on the command line). It doesn't seem to happen with the + -- API; but just in case, we check that we still get the right messages + -- (and not, for instance, '[TH]' as the module name). + + writeIORef progressUpdatesRef [] + updateSession session upd2 $ \p -> do + progressUpdates <- readIORef progressUpdatesRef + writeIORef progressUpdatesRef (progressUpdates ++ [p]) + assertNoErrors session + + do progressUpdates <- readIORef progressUpdatesRef + assertEqual "" [(1, 2, Just "Compiling A"), (2, 2, Just "Compiling Main")] + (map abstract progressUpdates) + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "A.hs" . L.unlines $ + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A where" + , "import Language.Haskell.TH" + , "foo :: Q Exp" + , "foo = [| True |]" + ]) + <> (updateSourceFile "Main.hs" . L.unlines $ + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module Main where" + , "import A" + , "main :: IO ()" + , "main = print $foo" + ]) + + upd2 = (updateSourceFile "A.hs" . L.unlines $ + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A where" + , "import Language.Haskell.TH" + , "foo :: Q Exp" + , "foo = [| False |]" + ]) + + abstract (Progress {..}) = ( progressStep + , progressNumSteps + , T.unpack `liftM` progressParsedMsg + ) + +test_RejectMangledHeader :: TestSuiteEnv -> Assertion +test_RejectMangledHeader env = withAvailableSession env $ \session -> do + updateSessionD session update 1 + assertSourceErrors' session ["parse error on input `very'"] + + updateSessionD session update2 1 + assertSourceErrors' session ["parse error on input `.'"] + where + update = updateSourceFile "M.hs" "module very-wrong where" + update2 = updateSourceFile "M.hs" "module M.1.2.3.8.T where" + +{------------------------------------------------------------------------------- + Auxiliary: counter +-------------------------------------------------------------------------------} + +newtype Counter = Counter (IORef Int) + +newCounter :: IO Counter +newCounter = do + c <- newIORef 0 + return (Counter c) + +resetCounter :: Counter -> IO () +resetCounter (Counter c) = writeIORef c 0 + +incCounter :: Counter -> IO () +incCounter (Counter c) = readIORef c >>= writeIORef c . (+ 1) + +assertCounter :: Counter -> Int -> Assertion +assertCounter (Counter c) i = do + j <- readIORef c + assertEqual "" i j diff --git a/TestSuite/TestSuite/Tests/Compliance.hs b/TestSuite/TestSuite/Tests/Compliance.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/Compliance.hs @@ -0,0 +1,144 @@ +module TestSuite.Tests.Compliance (testGroupCompliance) where + +import Prelude hiding (span, mod) +import Data.Monoid +import System.FilePath +import Test.HUnit +import Test.Tasty + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupCompliance :: TestSuiteEnv -> TestTree +testGroupCompliance env = testGroup "Standards compliance" [ + testGroup "NondecreasingIndentation" $ [ + stdTest env "GHC API should fail without -XNondecreasingIndentation" test_failWithoutXNDI_GHC + , stdTest env "both should pass with -XNondecreasingIndentation" test_passWithXNDI + , stdTest env "both should pass with -XNondecreasingIndentation in SessionConfig" test_passWithXNDI_asStaticOpt + , stdTest env "both should pass with -XHaskell98" test_passWithXH98 + , stdTest env "both should pass with -XHaskell98 in SessionConfig" test_passWithXH98_asStaticOpt + ] ++ exeTests env [ + stdTest env "buildExe should fail without -XNondecreasingIndentation" test_failWithoutXNDI_buildExe + ] + ] + +test_failWithoutXNDI_GHC :: TestSuiteEnv -> Assertion +test_failWithoutXNDI_GHC env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + -- The error messages are different in 7.4 and 7.8. + -- TODO: can use 'env' to have different assertions for 7.4 and 7.8 + assertOneError session + where + src = "module Main where\n\ + \main = do\n\ + \ let foo = do\n\ + \ putStrLn \"hello\"\n\ + \ foo" + upd = updateSourceFile "src/Main.hs" src + +test_failWithoutXNDI_buildExe :: TestSuiteEnv -> Assertion +test_failWithoutXNDI_buildExe env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + let m = "Main" + updE = buildExe ["-XHaskell2010"] [(m, "src/Main.hs")] + updateSessionD session updE 1 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + -- The error messages are different in 7.4 and 7.8. + -- TODO: can use 'env' to have different assertions for 7.4 and 7.8 + assertEqual "buildStderr empty" False (null buildStderr) + where + src = "module Main where\n\ + \main = do\n\ + \ let foo = do\n\ + \ putStrLn \"hello\"\n\ + \ foo" + upd = updateSourceFile "src/Main.hs" src + <> updateGhcOpts ["-XHaskell98"] + +test_passWithXNDI :: TestSuiteEnv -> Assertion +test_passWithXNDI env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + ifTestingExe env $ do + let m = "Main" + updE = buildExe [] [(m, "src/Main.hs")] + updateSessionD session updE 1 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" True (null buildStderr) + where + src = "module Main where\n\ + \main = do\n\ + \ let foo = do\n\ + \ putStrLn \"hello\"\n\ + \ foo" + upd = updateSourceFile "src/Main.hs" src + <> updateGhcOpts ["-XNondecreasingIndentation"] + +test_passWithXNDI_asStaticOpt :: TestSuiteEnv -> Assertion +test_passWithXNDI_asStaticOpt env = withAvailableSession' env (withGhcOpts ["-XNondecreasingIndentation"]) $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + ifTestingExe env $ do + let m = "Main" + updE = buildExe [] [(m, "src/Main.hs")] + updateSessionD session updE 1 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" True (null buildStderr) + where + src = "module Main where\n\ + \main = do\n\ + \ let foo = do\n\ + \ putStrLn \"hello\"\n\ + \ foo" + upd = updateSourceFile "src/Main.hs" src + +test_passWithXH98 :: TestSuiteEnv -> Assertion +test_passWithXH98 env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + ifTestingExe env $ do + let m = "Main" + updE = buildExe [] [(m, "src/Main.hs")] + updateSessionD session updE 2 -- Should be 1 (#189) + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" True (null buildStderr) + where + src = "module Main where\n\ + \main = do\n\ + \ let foo = do\n\ + \ putStrLn \"hello\"\n\ + \ foo" + upd = updateSourceFile "src/Main.hs" src + <> updateGhcOpts ["-XHaskell98"] + + +test_passWithXH98_asStaticOpt :: TestSuiteEnv -> Assertion +test_passWithXH98_asStaticOpt env = withAvailableSession' env (withGhcOpts ["-XHaskell98"]) $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + ifTestingExe env $ do + let m = "Main" + updE = buildExe [] [(m, "src/Main.hs")] + updateSessionD session updE 2 -- Should be 1 (#189) + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" True (null buildStderr) + where + src = "module Main where\n\ + \main = do\n\ + \ let foo = do\n\ + \ putStrLn \"hello\"\n\ + \ foo" + upd = updateSourceFile "src/Main.hs" src diff --git a/TestSuite/TestSuite/Tests/Concurrency.hs b/TestSuite/TestSuite/Tests/Concurrency.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/Concurrency.hs @@ -0,0 +1,107 @@ +module TestSuite.Tests.Concurrency (testGroupConcurrency) where + +import Prelude hiding (span, mod) +import Control.Concurrent +import Control.Monad +import Data.Monoid +import Test.HUnit +import Test.Tasty +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L (unlines) +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.ByteString as S +import qualified Data.ByteString.UTF8 as S + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupConcurrency :: TestSuiteEnv -> TestTree +testGroupConcurrency env = testGroup "Concurrency" [ + stdTest env "Concurrent snippets 1: Run same snippet multiple times" testSameSnippet + , stdTest env "Concurrent snippets 2: Execute different snippets concurrently" testDifferentSnippets + ] + +testSameSnippet :: TestSuiteEnv -> Assertion +testSameSnippet env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + -- Execute all snippets, but leave them waiting for input + snippets <- forM ["foo", "bar", "baz", "Foo", "Bar", "Baz", "FOO", "BAR", "BAZ"] $ \str -> do + let expectedResult = L.concat (replicate 100 (L.fromString (str ++ "\n"))) + runActions <- runStmt session "M" "echo" + return (runActions, str, expectedResult) + + -- Start all snippets and collect all their output concurrently + testResults <- forM snippets $ \(runActions, str, _expectedResult) -> do + testResult <- newEmptyMVar + _ <- forkIO $ do + supplyStdin runActions (S.fromString (str ++ "\n")) + putMVar testResult =<< runWaitAll' runActions + return testResult + + -- Wait for all test results, and compare against expected results + forM_ (zip snippets testResults) $ \((_runActions, _str, expectedResult), testResult) -> do + (output, result) <- takeMVar testResult + assertEqual "" RunOk result + assertEqual "" expectedResult output + where + upd = (updateCodeGeneration True) + <> (updateStdoutBufferMode $ RunLineBuffering Nothing) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Control.Monad" + , "echo :: IO ()" + , "echo = do str <- getLine" + , " replicateM_ 100 $ putStrLn str" + ]) + +testDifferentSnippets :: TestSuiteEnv -> Assertion +testDifferentSnippets env = withAvailableSession env $ \session -> do + -- Execute all snippets, but leave them waiting for input + snippets <- forM ["foo", "bar", "baz", "Foo", "Bar", "Baz", "FOO", "BAR", "BAZ"] $ \str -> do + let upd = (updateCodeGeneration True) + <> (updateStdoutBufferMode $ RunLineBuffering Nothing) + <> (updateSourceFile "M.hs" $ L.fromString . unlines $ + [ "module M where" + , "import Control.Monad" + , "echo :: IO ()" + , "echo = do _waiting <- getLine" + , " replicateM_ 100 $ putStrLn " ++ show str + ]) + updateSessionD session upd 1 + assertNoErrors session + + let expectedResult = L.concat (replicate 100 (L.fromString (str ++ "\n"))) + runActions <- runStmt session "M" "echo" + return (runActions, expectedResult) + + -- Start all snippets and collect all their output concurrently + testResults <- forM snippets $ \(runActions, _expectedResult) -> do + testResult <- newEmptyMVar + _ <- forkIO $ do + supplyStdin runActions "\n" + putMVar testResult =<< runWaitAll' runActions + return testResult + + -- Wait for all test results, and compare against expected results + forM_ (zip snippets testResults) $ \((_runActions, expectedResult), testResult) -> do + (output, result) <- takeMVar testResult + assertEqual "" RunOk result + assertEqual "" expectedResult output + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +runWaitAll' :: forall a. RunActions a -> IO (L.ByteString, a) +runWaitAll' RunActions{runWait} = go [] + where + go :: [S.ByteString] -> IO (L.ByteString, a) + go acc = do + resp <- runWait + case resp of + Left bs -> go (bs : acc) + Right runResult -> return (L.fromChunks (reverse acc), runResult) diff --git a/TestSuite/TestSuite/Tests/Crash.hs b/TestSuite/TestSuite/Tests/Crash.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/Crash.hs @@ -0,0 +1,252 @@ +module TestSuite.Tests.Crash (testGroupCrash) where + +import Prelude hiding (span) +import Control.Concurrent +import Control.Monad +import Data.Monoid +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.Lazy.Char8 as L (unlines) + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupCrash :: TestSuiteEnv -> TestTree +testGroupCrash env = testGroup "GHC crash" [ + stdTest env "GHC crash 1: No delay, no further requests" test_NoDelay_NoFurtherRequests + , stdTest env "GHC crash 2: No delay, follow up request" test_NoDelay_FollowUpRequest + , stdTest env "GHC crash 3: Delay, follow up request" test_Delay_FollowUpRequest + , stdTest env "GHC crash 4: Make sure session gets restarted on second update" test_SessionRestart + , stdTest env "GHC crash 5: Repeated crashes and restarts" test_RepeatedCrashes + , stdTest env "GHC crash 6: Add additional code after update" test_AddCode + , stdTest env "GHC crash 7: Update imported module after update" test_ImportedModule + , stdTest env "GHC crash 8: Update importing module after update" test_ImportingModule + ] + +test_NoDelay_NoFurtherRequests :: TestSuiteEnv -> Assertion +test_NoDelay_NoFurtherRequests env = withAvailableSession env $ \session -> do + crashGhcServer session Nothing + +test_NoDelay_FollowUpRequest :: TestSuiteEnv -> Assertion +test_NoDelay_FollowUpRequest env = withAvailableSession env $ \session -> do + crashGhcServer session Nothing + updateSession session (updateEnv [("Foo", Nothing)]) (\_ -> return ()) + actualErrs <- getSourceErrors session + assertEqual "" expectedErrs actualErrs + where + expectedErrs = [ + SourceError { + errorKind = KindServerDied + , errorSpan = TextSpan "<>" + , errorMsg = "user error (Intentional crash)" + } + ] + +test_Delay_FollowUpRequest :: TestSuiteEnv -> Assertion +test_Delay_FollowUpRequest env = withAvailableSession env $ \session -> do + crashGhcServer session (Just 1000000) + updateSession session (updateEnv [("Foo", Just "1")]) (\_ -> return ()) + threadDelay 2000000 + updateSession session (updateEnv [("Foo", Just "2")]) (\_ -> return ()) + assertSourceErrors' session ["Intentional crash"] + +test_SessionRestart :: TestSuiteEnv -> Assertion +test_SessionRestart env = withAvailableSession env $ \session -> do + -- Compile some code + updateSessionP session upd compilingProgress + assertNoErrors session + + -- Now crash the server + crashGhcServer session Nothing + + -- The next request fails, and we get a source error + updateSessionP session (updateEnv [("Foo", Just "Value1")]) [] + assertSourceErrors' session ["Intentional crash"] + + -- The next request, however, succeeds (and restarts the server, + -- and recompiles the code) + updateSessionP session (updateEnv [("Foo", Just "Value2")]) compilingProgress + + -- The code should have recompiled and we should be able to execute it + do runActions <- runStmt session "M" "printFoo" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Value2" output + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import System.Environment (getEnv)" + , "printFoo :: IO ()" + , "printFoo = getEnv \"Foo\" >>= putStr" + ]) + + compilingProgress = [(1, 1, "Compiling M")] + +test_RepeatedCrashes :: TestSuiteEnv -> Assertion +test_RepeatedCrashes env = withAvailableSession env $ \session -> do + -- Compile some code + updateSessionP session upd compilingProgress + assertNoErrors session + + -- We repeat the test of 'crash 4' a number of times + replicateM_ 5 $ do + -- Now crash the server + crashGhcServer session Nothing + + -- The next request fails, and we get a source error + updateSessionP session (updateEnv [("Foo", Just "Value1")]) [] + assertSourceErrors' session ["Intentional crash"] + + -- The next request, however, succeeds (and restarts the server, + -- and recompiles the code) + updateSessionP session (updateEnv [("Foo", Just "Value2")]) compilingProgress + + -- The code should have recompiled and we should be able to execute it + do runActions <- runStmt session "M" "printFoo" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Value2" output + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import System.Environment (getEnv)" + , "printFoo :: IO ()" + , "printFoo = getEnv \"Foo\" >>= putStr" + ]) + + compilingProgress = [(1, 1, "Compiling M")] + +test_AddCode :: TestSuiteEnv -> Assertion +test_AddCode env = withAvailableSession env $ \session -> do + updateSessionP session updA (compProgA 1) + assertNoErrors session + + -- Now crash the server + crashGhcServer session Nothing + + -- The next request fails, and we get a source error + updateSessionP session updB [] + assertSourceErrors' session ["Intentional crash"] + + -- The next request, however, succeeds (and restarts the server, + -- and recompiles the code) + updateSessionP session updB $ (compProgA 2 ++ compProgB 2) + + -- The code should have recompiled and we should be able to execute it + do runActions <- runStmt session "B" "printAB" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "AB" output + where + updA = (updateCodeGeneration True) + <> (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "printA :: IO ()" + , "printA = putStr \"A\"" + ]) + updB = (updateCodeGeneration True) + <> (updateSourceFile "B.hs" . L.unlines $ + [ "module B where" + , "import A" + , "printAB :: IO ()" + , "printAB = printA >> putStr \"B\"" + ]) + + compProgA n = [(1, n, "Compiling A")] + compProgB n = [(2, n, "Compiling B")] + +test_ImportedModule :: TestSuiteEnv -> Assertion +test_ImportedModule env = withAvailableSession env $ \session -> do + updateSessionP session (mconcat [updA, updB]) (compProgA 2 ++ compProgB 2) + assertNoErrors session + + -- Now crash the server + crashGhcServer session Nothing + + -- The next request fails, and we get a source error + let updA2 = (updateCodeGeneration True) + <> (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "printA :: IO ()" + , "printA = putStr \"A2\"" + ]) + updateSessionP session updA2 [] + assertSourceErrors' session ["Intentional crash"] + + -- The next request, however, succeeds (and restarts the server, + -- and recompiles the code) + updateSessionP session updA2 $ mconcat [compProgA 2, compProgB 2] + + -- The code should have recompiled and we should be able to execute it + do runActions <- runStmt session "B" "printAB" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "A2B" output + where + updA = (updateCodeGeneration True) + <> (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "printA :: IO ()" + , "printA = putStr \"A\"" + ]) + updB = (updateCodeGeneration True) + <> (updateSourceFile "B.hs" . L.unlines $ + [ "module B where" + , "import A" + , "printAB :: IO ()" + , "printAB = printA >> putStr \"B\"" + ]) + + compProgA n = [(1, n, "Compiling A")] + compProgB n = [(2, n, "Compiling B")] + + +test_ImportingModule :: TestSuiteEnv -> Assertion +test_ImportingModule env = withAvailableSession env $ \session -> do + updateSessionP session (mconcat [updA, updB]) (compProgA 2 ++ compProgB 2) + assertNoErrors session + + -- Now crash the server + crashGhcServer session Nothing + + -- The next request fails, and we get a source error + let updB2 = (updateCodeGeneration True) + <> (updateSourceFile "B.hs" . L.unlines $ + [ "module B where" + , "import A" + , "printAB :: IO ()" + , "printAB = printA >> putStr \"B2\"" + ]) + updateSessionP session updB2 [] + assertSourceErrors' session ["Intentional crash"] + + -- The next request, however, succeeds (and restarts the server, + -- and recompiles the code) + updateSessionP session updB2 $ mconcat [compProgA 2, compProgB 2] + + -- The code should have recompiled and we should be able to execute it + do runActions <- runStmt session "B" "printAB" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "AB2" output + where + updA = (updateCodeGeneration True) + <> (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "printA :: IO ()" + , "printA = putStr \"A\"" + ]) + updB = (updateCodeGeneration True) + <> (updateSourceFile "B.hs" . L.unlines $ + [ "module B where" + , "import A" + , "printAB :: IO ()" + , "printAB = printA >> putStr \"B\"" + ]) + + compProgA n = [(1, n, "Compiling A")] + compProgB n = [(2, n, "Compiling B")] diff --git a/TestSuite/TestSuite/Tests/Debugger.hs b/TestSuite/TestSuite/Tests/Debugger.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/Debugger.hs @@ -0,0 +1,147 @@ +module TestSuite.Tests.Debugger (testGroupDebugger) where + +import Prelude hiding (span, mod) +import Control.Monad +import Data.List (sort) +import Data.Monoid +import Test.HUnit +import Test.Tasty +import qualified Data.ByteString.Lazy.Char8 as L (unlines) +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupDebugger :: TestSuiteEnv -> TestTree +testGroupDebugger env = testGroup "Debugger" [ + stdTest env "Setting and clearing breakpoints" testSettingAndClearing + , stdTest env "Running until breakpoint, then resuming" testResuming + , stdTest env "Printing and forcing" testPrintingAndForcing + ] + +testSettingAndClearing :: TestSuiteEnv -> Assertion +testSettingAndClearing env = withAvailableSession env $ \session -> do + skipTest "Debugger API known broken" + + updateSessionD session qsort 1 + assertNoErrors session + + expTypes <- getExpTypes session + let (modName, mouseSpan) = mkSpan "Main" (2, 16, 2, 16) + fullSpan = fst . last $ expTypes modName mouseSpan + (_, wrongSpan) = mkSpan "Main" (0, 0, 0, 0) + + r1 <- setBreakpoint session modName fullSpan True + r2 <- setBreakpoint session modName fullSpan False + r3 <- setBreakpoint session modName fullSpan False + r4 <- setBreakpoint session modName wrongSpan True + assertEqual "original value of breakpoint" (Just False) r1 + assertEqual "breakpoint successfully set" (Just True) r2 + assertEqual "breakpoint successfully unset" (Just False) r3 + assertEqual "invalid breakpoint" Nothing r4 + +testResuming :: TestSuiteEnv -> Assertion +testResuming env = withAvailableSession env $ \session -> do + skipTest "Debugger API known broken" + + updateSessionD session qsort 1 + assertNoErrors session + + expTypes <- getExpTypes session + let (modName, mouseSpan) = mkSpan "Main" (2, 16, 2, 16) + fullSpan = fst . last $ expTypes modName mouseSpan + + Just False <- setBreakpoint session modName fullSpan True + + let inputList :: [Integer] + inputList = [8, 4, 0, 3, 1, 23, 11, 18] + + outputs <- forM (mark inputList) $ \(i, isFirst, _isLast) -> do + runActions <- if isFirst then runStmt session "Main" "main" + else resume session + (output, RunBreak) <- runWaitAll runActions + assertBreak session "Main" + "Main.hs@2:16-2:48" + "[a]" + [ ("_result" , "[Integer]" , "_") + , ("a" , "Integer" , show i) + , ("left" , "[Integer]" , "_") + , ("right" , "[Integer]" , "_") + ] + return output + + do runActions <- resume session + (finalOutput, finalResult) <- runWaitAll runActions + let output = L.concat $ outputs ++ [finalOutput] + assertEqual "" RunOk finalResult + assertEqual "" (show (sort inputList) ++ "\n") (L.toString output) + mBreakInfo <- getBreakInfo session + assertEqual "" Nothing mBreakInfo + +testPrintingAndForcing :: TestSuiteEnv -> Assertion +testPrintingAndForcing env = withAvailableSession env $ \session -> do + skipTest "Debugger API known broken" + + updateSessionD session qsort 1 + assertNoErrors session + + expTypes <- getExpTypes session + let (modName, mouseSpan) = mkSpan "Main" (2, 16, 2, 16) + fullSpan = fst . last $ expTypes modName mouseSpan + + Just False <- setBreakpoint session modName fullSpan True + runActions <- runStmt session "Main" "main" + (_output, RunBreak) <- runWaitAll runActions + + printed <- printVar session "left" True False + forced <- printVar session "left" True True + assertEqual "" [("left", "[Integer]", "(_t1::[Integer])")] printed + assertEqual "" [("left", "[Integer]", "[4, 0, 3, 1]")] forced + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +qsort :: IdeSessionUpdate +qsort = (updateSourceFile "Main.hs" . L.unlines $ [ + -- 1 2 3 4 5 + -- 12345678901234567890123456789012345678901234567890123456 + "qsort [] = [] " + , "qsort (a:as) = qsort left ++ [a] ++ qsort right" + , " where (left,right) = (filter (<=a) as, filter (>a) as)" + , "" + , "main = print (qsort [8, 4, 0, 3, 1, 23, 11, 18])" + ]) + <> (updateCodeGeneration True) + +-- | Mark each element of the list with booleans indicating whether it's the +-- first and/or the last element in the list +mark :: [a] -> [(a, Bool, Bool)] +mark [] = [] +mark [x] = [(x, True, True)] +mark (x:xs) = (x, True, False) : aux xs + where + aux [] = error "impossible" + aux [y] = [(y, False, True)] + aux (y:ys) = (y, False, False) : aux ys + +assertBreak :: IdeSession + -> String -- ^ Module + -> String -- ^ Location + -> String -- ^ Result type + -> [(String, String, String)] -- ^ Var, type, value + -> Assertion +assertBreak session mod loc resTy vars = do + Just BreakInfo{..} <- getBreakInfo session + assertEqual "module name" mod (T.unpack breakInfoModule) + assertEqual "location" loc (show breakInfoSpan) + assertAlphaEquiv "result type" resTy (T.unpack breakInfoResultType) + assertEqual "number of local vars" (length vars) (length breakInfoVariableEnv) + forM_ (zip vars breakInfoVariableEnv) $ \((var, typ, val), (var', typ', val')) -> do + assertEqual "var name" var (T.unpack var') + assertAlphaEquiv "var type" typ (T.unpack typ') + assertEqual "var val" val (T.unpack val') diff --git a/TestSuite/TestSuite/Tests/FFI.hs b/TestSuite/TestSuite/Tests/FFI.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/FFI.hs @@ -0,0 +1,541 @@ +module TestSuite.Tests.FFI (testGroupFFI) where + +import Data.Monoid +import Data.Version +import System.Directory +import System.Exit +import System.FilePath +import System.Process +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString as S +import qualified Data.ByteString.UTF8 as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L (unlines) +import qualified Data.Text as T + +import IdeSession +import TestSuite.Assertions +import TestSuite.Session +import TestSuite.State + +testGroupFFI :: TestSuiteEnv -> TestTree +testGroupFFI env = testGroup "Using the FFI" $ [ + stdTest env "via GHC API" test_FFI_via_API + , stdTest env "via GHC API with restartSession" test_FFI_via_API_restartSession + , stdTest env "via GHC API with deleting and re-adding the .c file" test_deleteReadd + , stdTest env "via GHC API with deleting and adding a different .c file" test_deleteAddDifferent + , stdTest env "with withIncludes, TH and MIN_VERSION_base via buildExe and with restartSession" test_MinVersion_restartSession + , stdTest env "with withIncludes and TargetsExclude" test_TargetsExclude + , stdTest env "with dynamic include, TH and MIN_VERSION_base via buildExe" test_DynamicInclude + , stdTest env "with dynamic include and TargetsInclude" test_DynamicInclude_TargetsInclude + , stdTest env "with setting SSE via GHC API (#218)" test_SSE_via_API + ] ++ exeTests env [ + stdTest env "from a subdir and compiled via buildExe" test_fromSubdir_buildExe + , stdTest env "with TH and MIN_VERSION_base via buildExe" test_MinVersion + , stdTest env "with withIncludes, TH and MIN_VERSION_base via buildExe" test_MinVersion_withIncludes + , stdTest env "with setting SSE via buildExe (#218)" test_SSE_via_buildExe + ] + +test_FFI_via_API :: TestSuiteEnv -> Assertion +test_FFI_via_API env = withAvailableSession env $ \session -> do + updateSessionD session upd 3 + assertNoErrors session + runActions <- runStmt session "Main" "main" + (output, result) <- runWaitAll runActions + case result of + RunOk -> assertEqual "" "42\n" output + _ -> assertFailure $ "Unexpected run result: " ++ show result + where + upd = mconcat [ + updateCodeGeneration True + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/life.c" + , updateSourceFileFromFile "TestSuite/inputs/FFI/life.h" + ] + +test_FFI_via_API_restartSession :: TestSuiteEnv -> Assertion +test_FFI_via_API_restartSession env = withAvailableSession env $ \session -> do + updateSessionD session upd 3 + assertNoErrors session + + restartSession session + updateSessionD session mempty 3 + assertNoErrors session + + runActions <- runStmt session "Main" "main" + (output, result) <- runWaitAll runActions + case result of + RunOk -> assertEqual "" "42\n" output + _ -> assertFailure $ "Unexpected run result: " ++ show result + where + upd = mconcat [ + updateCodeGeneration True + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/life.c" + , updateSourceFileFromFile "TestSuite/inputs/FFI/life.h" + ] + +test_deleteReadd :: TestSuiteEnv -> Assertion +test_deleteReadd env = withAvailableSession env $ \session -> do + updateSessionD session upd 3 + assertNoErrors session + + updateSessionD session (updateSourceFileDelete "TestSuite/inputs/FFI/life.c") 0 + assertNoErrors session + + updateSessionD session (updateSourceFileFromFile "TestSuite/inputs/FFI/life.c") 4 + assertNoErrors session + + updateSessionD session (updateSourceFileDelete "TestSuite/inputs/FFI/life.c") 0 + assertNoErrors session + + restartSession session + updateSessionD session mempty 1 + assertOneError session + + updateSessionD session (updateSourceFileFromFile "TestSuite/inputs/FFI/life.c") 4 + assertNoErrors session + + runActions <- runStmt session "Main" "main" + (output, result) <- runWaitAll runActions + case result of + RunOk -> assertEqual "" "42\n" output + _ -> assertFailure $ "Unexpected run result: " ++ show result + where + upd = mconcat [ + updateCodeGeneration True + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/life.c" + , updateSourceFileFromFile "TestSuite/inputs/FFI/life.h" + ] + +test_deleteAddDifferent :: TestSuiteEnv -> Assertion +test_deleteAddDifferent env = withAvailableSession env $ \session -> do + updateSessionD session upd 3 + assertNoErrors session + + updateSessionD session (updateSourceFileDelete "TestSuite/inputs/FFI/life.c" + <> updateSourceFileDelete "TestSuite/inputs/FFI/life.h") 0 + assertNoErrors session + +{- duplicate definition for symbol... errorMsg = "Server killed" + updateSessionD session (updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.c" + <> updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/local.h" + <> updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.h") 4 + assertNoErrors session + runActions <- runStmt session "Main" "main" + (output, result) <- runWaitAll runActions + case result of + RunOk -> assertEqual "" "42\n" output + _ -> assertFailure $ "Unexpected run result: " ++ show result +-} + where + upd = mconcat [ + updateCodeGeneration True + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/life.c" + , updateSourceFileFromFile "TestSuite/inputs/FFI/life.h" + ] + +test_fromSubdir_buildExe :: TestSuiteEnv -> Assertion +test_fromSubdir_buildExe env = withAvailableSession env $ \session -> do + updateSessionD session upd 3 + assertNoErrors session + let m = "Main" + upd2 = buildExe [] [(T.pack m, "TestSuite/inputs/FFI/Main2.hs")] + updateSessionD session upd2 1 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + exeOut <- readProcess (distDir "build" m m) [] [] + assertEqual "FFI exe output" "42\n" exeOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "42\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = mconcat [ + updateCodeGeneration True + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main2.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.c" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.h" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/local.h" + ] + +test_MinVersion :: TestSuiteEnv -> Assertion +test_MinVersion env = withAvailableSession env $ \session -> do + withCurrentDirectory "TestSuite/inputs/FFI" $ updateSessionD session upd 4 + assertNoErrors session + let m = "Main" + upd2 = buildExe [] [(T.pack m, "Main3.hs")] + updateSessionD session upd2 5 -- TODO: Some modules may be compiled twice (#189) + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + exeOut <- readProcess (distDir "build" m m) [] [] + assertEqual "FFI exe output" "84\n" exeOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "84\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = mconcat [ + updateCodeGeneration True + , updateSourceFileFromFile "Main3.hs" + , updateSourceFileFromFile "A.hs" + , updateSourceFileFromFile "ffiles/life.c" + , updateSourceFileFromFile "ffiles/life.h" + , updateSourceFileFromFile "ffiles/local.h" + ] + +test_MinVersion_withIncludes :: TestSuiteEnv -> Assertion +test_MinVersion_withIncludes env = withAvailableSession' env (withIncludes ["TestSuite/inputs/FFI"]) $ \session -> do + updateSessionD session upd 4 + assertNoErrors session + let m = "Main" + upd2 = buildExe [] [(T.pack m, "Main3.hs")] + updateSessionD session upd2 3 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + exeOut <- readProcess (distDir "build" m m) [] [] + assertEqual "FFI exe output" "84\n" exeOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "84\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = mconcat [ + updateCodeGeneration True + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main3.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/A.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.c" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.h" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/local.h" + ] + +test_MinVersion_restartSession :: TestSuiteEnv -> Assertion +test_MinVersion_restartSession env = withAvailableSession' env (withIncludes ["TestSuite/inputs/FFI"]) $ \session -> do + updateSessionD session upd 4 + assertNoErrors session + + restartSession session + updateSessionD session mempty 4 + assertNoErrors session + + updateSessionD session (updateSourceFileDelete "TestSuite/inputs/FFI/ffiles/life.c" + <> updateSourceFileDelete "TestSuite/inputs/FFI/ffiles/life.h" + <> updateSourceFileDelete "TestSuite/inputs/FFI/ffiles/local.h") 0 + assertNoErrors session + + restartSession session + updateSessionD session mempty 4 + assertOneError session + + updateSessionD session (updateSourceFileFromFile "TestSuite/inputs/FFI/life.h" + <> updateSourceFileFromFile "TestSuite/inputs/FFI/life.c") 4 + assertNoErrors session + + ifTestingExe env $ do + let m = "Main" + upd2 = buildExe [] [(T.pack m, "Main3.hs")] + updateSessionD session upd2 3 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + exeOut <- readProcess (distDir "build" m m) [] [] + assertEqual "FFI exe output" "84\n" exeOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "84\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = mconcat [ + updateCodeGeneration True + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main3.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/A.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.c" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.h" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/local.h" + ] + +test_TargetsExclude :: TestSuiteEnv -> Assertion +test_TargetsExclude env = withAvailableSession' env (withIncludes ["TestSuite/inputs/FFI"]) $ \session -> do + updateSessionD session upd 4 + assertNoErrors session + updateSessionD session (updateSourceFileDelete "TestSuite/inputs/FFI/ffiles/life.c") 0 + assertNoErrors session + + restartSession session + updateSessionD session mempty 1 + assertOneError session + + -- Without the restartSession we get +{- +GHCi runtime linker: fatal error: I found a duplicate definition for symbol + meaningOfLife +whilst processing object file + /tmp/ide-backend-test.28928/dist.28928/objs/TestSuite/inputs/FFI/ffiles/life.o +This could be caused by: + * Loading two different object files which export the same symbol + * Specifying the same object file twice on the GHCi command line + * An incorrect `package.conf' entry, causing some object to be + loaded twice. +GHCi cannot safely continue in this situation. Exiting now. Sorry. + + Using the FFI via GHC API with deleting and adding a different .c file: [Failed] +Unexpected errors: SourceError {errorKind = KindServerDied, errorSpan = <>, errorMsg = "Server killed"} +-} + updateSessionD session (updateSourceFileFromFile "TestSuite/inputs/FFI/life.c" + <> updateSourceFileFromFile "TestSuite/inputs/FFI/life.h") 5 + assertNoErrors session + + distDir <- getDistDir session + ifTestingExe env $ do + let m = "Main" + upd2 = buildExe [] [(T.pack m, "Main3.hs")] + updateSessionD session upd2 4 + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + exeOut <- readProcess (distDir "build" m m) [] [] + assertEqual "FFI exe output" "84\n" exeOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "84\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + + -- This is the one test where test the .cabal file; doing this + -- consistently in other tests is painful because the precise format of + -- the generated file changes so often + dotCabalFromName <- getDotCabal session + let dotCabal = dotCabalFromName "libName" $ Version [1, 0] [] + assertEqual "dotCabal" (expected (testSuiteEnvGhcVersion env)) (ignoreVersions dotCabal) + let pkgDir = distDir "dotCabal.test" + createDirectoryIfMissing False pkgDir + L.writeFile (pkgDir "libName.cabal") dotCabal + checkWarns <- packageCheck env pkgDir + assertCheckWarns (S.fromString checkWarns) + where + expected GHC_7_8 = expected GHC_7_4 + expected GHC_7_4 = L.unlines [ + "name: libName" + , "version: X.Y.Z" + , "cabal-version: X.Y.Z" + , "build-type: Simple" + , "license: AllRightsReserved" + , "" + , "library" + , " build-depends:" + , " array ==X.Y.Z," + , " base ==X.Y.Z," + , " containers ==X.Y.Z," + , " deepseq ==X.Y.Z," + , " ghc-prim ==X.Y.Z," + , " integer-gmp ==X.Y.Z," + , " pretty ==X.Y.Z," + , " template-haskell ==X.Y.Z" + , " exposed-modules:" + , " A" + , " c-sources:" + , " TestSuite/inputs/FFI/life.c" + , " default-language: Haskell2010" + , " other-extensions: TemplateHaskell" + , " install-includes:" + , " life.h" + , " local.h" + , " life.h" + , " hs-source-dirs: TestSuite/inputs/FFI" + , "" + ] + expected GHC_7_10 = L.unlines [ + "name: libName" + , "version: X.Y.Z" + , "cabal-version: X.Y.Z" + , "build-type: Simple" + , "license: AllRightsReserved" + , "" + , "library" + , " build-depends:" + , " array ==X.Y.Z," + , " base ==X.Y.Z," + , " deepseq ==X.Y.Z," + , " ghc-prim ==X.Y.Z," + , " integer-gmp ==X.Y.Z," + , " pretty ==X.Y.Z," + , " template-haskell ==X.Y.Z" + , " exposed-modules:" + , " A" + , " c-sources:" + , " TestSuite/inputs/FFI/life.c" + , " default-language: Haskell2010" + , " other-extensions: TemplateHaskell" + , " install-includes:" + , " life.h" + , " local.h" + , " life.h" + , " hs-source-dirs: TestSuite/inputs/FFI" + , "" + ] + + upd = mconcat [ + updateCodeGeneration True + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main2.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main3.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/A.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.c" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.h" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/local.h" + , updateTargets (TargetsExclude ["TestSuite/inputs/FFI/life.c", "TestSuite/inputs/FFI/life.h", "life.c", "life.h", "TestSuite/inputs/FFI/Main.hs", "TestSuite/inputs/FFI/Main2.hs"]) + ] + +test_DynamicInclude :: TestSuiteEnv -> Assertion +test_DynamicInclude env = withAvailableSession env $ \session -> do + updateSessionD session + (updateRelativeIncludes []) + 0 + updateSessionD session upd 4 + assertNoErrors session + + updateSessionD session + (updateRelativeIncludes ["TestSuite/inputs/FFI"]) + 4 + assertNoErrors session + + ifTestingExe env $ do + let m = "Main" + upd2 = buildExe [] [(T.pack m, "Main3.hs")] + updateSessionD session upd2 3 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + exeOut <- readProcess (distDir "build" m m) [] [] + assertEqual "FFI exe output" "84\n" exeOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "84\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = mconcat [ + updateCodeGeneration True + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main3.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/A.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.c" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.h" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/local.h" + ] + +test_DynamicInclude_TargetsInclude :: TestSuiteEnv -> Assertion +test_DynamicInclude_TargetsInclude env = withAvailableSession env $ \session -> do + updateSessionD session upd 4 + assertNoErrors session + + updateSessionD session + (updateRelativeIncludes ["TestSuite/inputs/FFI"]) + 4 + assertNoErrors session + + updateSessionD session (updateTargets (TargetsInclude ["TestSuite/inputs/FFI/Main2.hs"])) 3 + assertNoErrors session + + updateSessionD session (updateTargets (TargetsInclude ["TestSuite/inputs/FFI/Main3.hs"])) 4 + assertNoErrors session + + ifTestingExe env $ do + let m = "Main" + upd2 = buildExe [] [(T.pack m, "Main3.hs")] + updateSessionD session upd2 4 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + exeOut <- readProcess (distDir "build" m m) [] [] + assertEqual "FFI exe output" "84\n" exeOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "84\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = mconcat [ + updateCodeGeneration True + , updateTargets (TargetsInclude ["TestSuite/inputs/FFI/Main.hs"]) + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main2.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/Main3.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/A.hs" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.c" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/life.h" + , updateSourceFileFromFile "TestSuite/inputs/FFI/ffiles/local.h" + ] + +test_SSE_via_API :: TestSuiteEnv -> Assertion +test_SSE_via_API env = withAvailableSession env $ \session -> do + updateSessionD session upd 3 + assertNoErrors session + runActions <- runStmt session "Main" "main" + (output, result) <- runWaitAll runActions + case result of + RunOk -> assertEqual "" "42\n" output + _ -> assertFailure $ "Unexpected run result: " ++ show result + where + upd = mconcat [ + updateCodeGeneration True + , updateSourceFile "test.c" "#include \nint meaningOfLife() { return 42; }" -- TODO: actually call any SSE op + , updateSourceFile "Main.hs" "{-# LANGUAGE ForeignFunctionInterface #-}\nforeign import ccall meaningOfLife :: IO Int\nmain :: IO ()\nmain = print =<< meaningOfLife" + , updateGhcOpts ["-optc-msse4"] + ] + +test_SSE_via_buildExe :: TestSuiteEnv -> Assertion +test_SSE_via_buildExe env = withAvailableSession env $ \session -> do + updateSessionD session upd 3 + assertNoErrors session + let m = "Main" + upd2 = buildExe [] [(T.pack m, "Main.hs")] + updateSessionD session upd2 2 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + exeOut <- readProcess (distDir "build" m m) [] [] + assertEqual "FFI exe output" "42\n" exeOut + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "42\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = mconcat [ + updateCodeGeneration True + , updateSourceFile "test.c" "#include \nint meaningOfLife() { return 42; }" -- TODO: actually call any SSE op + , updateSourceFile "Main.hs" "{-# LANGUAGE ForeignFunctionInterface #-}\nforeign import ccall meaningOfLife :: IO Int\nmain :: IO ()\nmain = print =<< meaningOfLife" + , updateGhcOpts ["-optc-msse4"] + ] + + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +assertCheckWarns :: S.ByteString -> Assertion +assertCheckWarns warns = do + expect "No 'category' field" + expect "No 'maintainer' field" + expect "The package is missing a Setup.hs or Setup.lhs script" + expect "No 'synopsis' or 'description' field" + where + expect :: S.ByteString -> Assertion + expect str = assertBool ("Expected " ++ show str) (str `S.isInfixOf` warns) diff --git a/TestSuite/TestSuite/Tests/Integration.hs b/TestSuite/TestSuite/Tests/Integration.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/Integration.hs @@ -0,0 +1,193 @@ +-- | Rather than doing spot-checks for specific features, load some bigger +-- projects and make sure nothing goes horribly wrong +module TestSuite.Tests.Integration (testGroupIntegration) where + +import Control.Exception +import Control.Monad +import Data.Monoid +import System.Exit +import Test.Tasty +import Test.HUnit hiding (test) + +import IdeSession +import TestSuite.Assertions +import TestSuite.Session +import TestSuite.State + +testGroupIntegration :: TestSuiteEnv -> TestTree +testGroupIntegration env = testGroup "Integration" $ integrationTests env [ + integrationTest env "Run the sample code; succeed or raise an exception" test_runSampleCode + , integrationTest env "Overwrite with error" test_overwriteWithError + , integrationTest env "Overwrite with the same module name in all files" test_overwriteWithSameModuleName + , integrationTest env "Overwrite modules many times" test_overwriteModulesManyTimes + , integrationTest env "Overwrite all with exception-less code and run it" test_overwriteWithExceptionFreeCode + , integrationTest env "Make sure deleting modules removes them from the directory" test_deletingModulesRemovesFiles + , integrationTest env "Make sure restartSession does not lose source files" test_dontLoseFilesInRestart + ] + +{------------------------------------------------------------------------------- + "Projects" setup +-------------------------------------------------------------------------------} + +type IntegrationTest = IdeSession -> IdeSessionUpdate -> [String] -> Assertion + +integrationTest :: TestSuiteEnv -> String -> IntegrationTest -> TestTree +integrationTest env name test = testGroup name $ + map (testWithProject env test) (projects env) + +testWithProject :: TestSuiteEnv -> IntegrationTest -> Project -> TestTree +testWithProject env test Project{..} = do + stdTest env projectName $ \env' -> do + (upd, lm) <- getModulesFrom projectSourcesDir + withAvailableSession' env' cfg $ \session -> test session upd lm + where + cfg = withModInfo False + . withGhcOpts projectOptions + +data Project = Project { + projectName :: String + , projectSourcesDir :: FilePath + , projectOptions :: [String] + } + +-- Set of projects and options to use for them. +projects :: TestSuiteEnv -> [Project] +projects env = [ + Project { + projectName = "A depends on B, throws exception" + , projectSourcesDir = "TestSuite/inputs/ABnoError" + , projectOptions = [] + } + , Project { + projectName = "Cabal code" + , projectSourcesDir = testInputPathCabal env + , projectOptions = [] + } + , Project { + projectName = "A single file with a code to run in parallel" + , projectSourcesDir = "TestSuite/inputs/MainModule" + , projectOptions = [] + } + ] + +{------------------------------------------------------------------------------- + The tests we run on each project +-------------------------------------------------------------------------------} + +test_overwriteWithError :: IntegrationTest +test_overwriteWithError session originalUpdate lm = do + updateSessionD session originalUpdate (length lm) + -- No errors in the original test code. + assertNoErrors session + -- Overwrite one of the copied files. + (_, ms) <- getModules session + let update = loadModule (head ms) "a = unknownX" + updateSessionD session update (length ms) -- we don't know how many modules get recompiled + assertSourceErrors' session ["Not in scope: `unknownX'"] + +test_overwriteWithSameModuleName :: IntegrationTest +test_overwriteWithSameModuleName session originalUpdate lm = do + updateSessionD session update 2 + if length lm >= 2 + then assertSourceErrors' session ["defined in multiple files"] + else assertNoErrors session + where + upd m = updateSourceFile m "module Wrong where\na = 1" + update = originalUpdate <> mconcat (map upd lm) + +test_overwriteModulesManyTimes :: IntegrationTest +test_overwriteModulesManyTimes session originalUpdate lm0 = do + let doubleUpdate = mempty <> originalUpdate <> originalUpdate <> mempty + -- Updates are idempotent, so no errors and no recompilation. + updateSessionD session doubleUpdate (length lm0) + assertNoErrors session + -- Overwrite one of the copied files with an error. + (_, lm) <- getModules session + let update1 = updateCodeGeneration False + <> loadModule (head lm) "a = unknownX" + updateSessionD session update1 (length lm) + assertSourceErrors' session ["Not in scope: `unknownX'"] + updateSessionD session mempty 1 -- was an error, so trying again + assertSourceErrors' session ["Not in scope: `unknownX'"] + -- Overwrite all files, many times, with correct code eventually. + let upd m = loadModule m "x = unknownX" + <> loadModule m "y = 2" + <> updateCodeGeneration True + update2 = mconcat $ map upd lm + updateSessionD session update2 (length lm) + assertNoErrors session + -- Overwrite again with the error. + updateSessionD session update1 1 -- drop bytecode, don't recompile + assertSourceErrors' session ["Not in scope: `unknownX'"] + assertRaises "runStmt session Main main" + (== userError "Cannot run before the code is generated.") + (runStmt session "Main" "main") + +test_runSampleCode :: IntegrationTest +test_runSampleCode session originalUpdate lm = do + updateSessionD session originalUpdate (length lm) + updateSessionD session update (length lm) -- all recompiled + assertNoErrors session + mex <- try $ runStmt session "Main" "main" + case mex of + Right runActions -> void $ runWaitAll runActions + Left ex -> assertEqual "runStmt" (userError "Module \"Main\" not successfully loaded, when trying to run code.") ex + where + update = updateCodeGeneration True + +test_overwriteWithExceptionFreeCode :: IntegrationTest +test_overwriteWithExceptionFreeCode session originalUpdate lm = do + -- Compile from scratch, generating code from the start. + updateSessionD session update2 (length lm + 1) + assertNoErrors session + runActions <- runStmt session "Central.TotallyMain" "main" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" output "\"test run\"\n" + where + upd m = loadModule m "x = 1" + update = originalUpdate + <> updateSourceFile + "Central/TotallyMain.hs" + "module Central.TotallyMain where\nmain = print \"test run\"" + <> mconcat (map upd lm) + update2 = update <> updateCodeGeneration True + +test_deletingModulesRemovesFiles :: IntegrationTest +test_deletingModulesRemovesFiles session originalUpdate lm = do + updateSessionD session originalUpdate (length lm) + updateSessionD session updateDel 0 + assertNoErrors session + -- The updates cancel each other out. + updateSessionD session (originalUpdate <> updateDel) 0 + updateSessionD session update2 0 -- 0: nothing to generate code from + assertNoErrors session + where + updateDel = mconcat $ map updateSourceFileDelete lm + update2 = updateCodeGeneration True + +test_dontLoseFilesInRestart :: IntegrationTest +test_dontLoseFilesInRestart session originalUpdate lm = do + updateSessionD session update (length lm) + serverBefore <- getGhcServer session + mex <- try $ runStmt session "Main" "main" + case mex of + Right _runActions -> return () -- don't runWaitAll + Left ex -> assertEqual "runStmt" (userError "Module \"Main\" not successfully loaded, when trying to run code.") ex + restartSession session + updateSessionD session mempty (length lm) -- all compiled anew + assertNoErrors session + mex2 <- try $ runStmt session "Main" "main" + case mex2 of + Right runActions -> void $ runWaitAll runActions -- now runWaitAll + Left ex -> assertEqual "runStmt" (userError "Module \"Main\" not successfully loaded, when trying to run code.") ex + restartSession session + updateSessionD session update2 0 -- if any file missing, would yell + assertNoErrors session + updateSessionD session update3 0 -- 0: nothing to generate code from + exitCodeBefore <- getGhcExitCode serverBefore + assertEqual "exitCodeBefore" (Just (ExitFailure (-9))) exitCodeBefore -- SIGKILL + where + update = originalUpdate <> updateCodeGeneration True + update2 = mconcat $ map updateSourceFileDelete lm + update3 = updateCodeGeneration True diff --git a/TestSuite/TestSuite/Tests/InterruptRunExe.hs b/TestSuite/TestSuite/Tests/InterruptRunExe.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/InterruptRunExe.hs @@ -0,0 +1,117 @@ +module TestSuite.Tests.InterruptRunExe (testGroupInterruptRunExe) where + +import Control.Concurrent +import Control.Monad +import Data.Monoid +import System.Exit +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.Lazy.Char8 as L (unlines) +import qualified Data.Text as T + +import IdeSession +import TestSuite.Assertions +import TestSuite.Session +import TestSuite.State + +testGroupInterruptRunExe :: TestSuiteEnv -> TestTree +testGroupInterruptRunExe env = testGroup "Interrupt runExe" $ exeTests env [ + stdTest env "After 1 sec" testAfter1sec + , stdTest env "Immediately" testImmediately + , stdTest env "Black hole, after 1 sec)" testBlackHole + , stdTest env "Many times, preferably without deadlock (#58)" testManyTimes + ] + +testAfter1sec :: TestSuiteEnv -> Assertion +testAfter1sec env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + threadDelay 1000000 + interrupt runActionsExe + resOrEx <- runWait runActionsExe + case resOrEx of + Right result -> assertEqual "after runExe" (ExitFailure (-2)) result -- SIGINT + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Control.Concurrent (threadDelay)" + , "main :: IO ()" + , "main = threadDelay 100000 >> main" + ]) + +testImmediately :: TestSuiteEnv -> Assertion +testImmediately env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 3 -- TODO: Some modules may be compiled twice (#189) + runActionsExe <- runExe session m + interrupt runActionsExe + resOrEx <- runWait runActionsExe + case resOrEx of + Right result -> assertEqual "after runExe" (ExitFailure (-2)) result -- SIGINT + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Control.Concurrent (threadDelay)" + , "main :: IO ()" + , "main = threadDelay 100000 >> main" + ]) + +testBlackHole :: TestSuiteEnv -> Assertion +testBlackHole env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + threadDelay 1000000 + resOrExe <- runWait runActionsExe + -- Here the result differs from runStmt, because the loop is detected + -- and reported. + case resOrExe of + Left result -> assertEqual "after runExe" "M: <>\n" result + _ -> assertFailure $ "Unexpected run result: " ++ show resOrExe + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "main :: IO ()" + , "main = main" + ]) + +testManyTimes :: TestSuiteEnv -> Assertion +testManyTimes env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + let m = "Main" + updExe = buildExe [] [(T.pack m, "Main.hs")] + updateSessionD session updExe 2 + + replicateM_ 10 $ do + runActionsExe <- runExe session m + interrupt runActionsExe + (_output, result) <- runWaitAll runActionsExe + assertEqual "" (ExitFailure (-2)) result -- SIGINT + + -- This doesn't work, because the updateStdoutBufferMode above + -- is void for runExe. + -- runActions <- runExe session m + -- result <- runWait runActions + -- assertEqual "" (Left (BSSC.pack "Hi!\n")) result + -- interrupt runActions -- needed, because exe not killed by shutdown + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "Main.hs" "main = putStrLn \"Hi!\" >> getLine") + <> (updateStdoutBufferMode (RunLineBuffering Nothing)) diff --git a/TestSuite/TestSuite/Tests/InterruptRunStmt.hs b/TestSuite/TestSuite/Tests/InterruptRunStmt.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/InterruptRunStmt.hs @@ -0,0 +1,100 @@ +module TestSuite.Tests.InterruptRunStmt (testGroupInterruptRunStmt) where + +import Control.Concurrent +import Control.Monad +import Data.Monoid +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.Lazy.Char8 as L (unlines) + +import IdeSession +import TestSuite.Assertions +import TestSuite.Session +import TestSuite.State + +testGroupInterruptRunStmt :: TestSuiteEnv -> TestTree +testGroupInterruptRunStmt env = testGroup "Interrupt runStmt" [ + stdTest env "After 1 sec" testAfter1sec + , stdTest env "Immediately" testImmediately + , stdTest env "Black hole, after 1 sec)" testBlackHole + , stdTest env "Many times, preferably without deadlock (#58)" testManyTimes + ] + +testAfter1sec :: TestSuiteEnv -> Assertion +testAfter1sec env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "loop" + threadDelay 1000000 + interrupt runActions + resOrEx <- runWait runActions + case resOrEx of + Right result -> assertBool "" (isAsyncException result) + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Control.Concurrent (threadDelay)" + , "loop :: IO ()" + , "loop = threadDelay 100000 >> loop" + ]) + +testImmediately :: TestSuiteEnv -> Assertion +testImmediately env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "loop" + interrupt runActions + resOrEx <- runWait runActions + case resOrEx of + Right result -> assertBool "" (isAsyncException result) + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Control.Concurrent (threadDelay)" + , "loop :: IO ()" + , "loop = threadDelay 100000 >> loop" + ]) + +testBlackHole :: TestSuiteEnv -> Assertion +testBlackHole env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "loop" + threadDelay 1000000 + forceCancel runActions -- Black hole cannot (always) be interrupted using an exception + resOrEx <- runWait runActions + case resOrEx of + Right RunForceCancelled -> return () + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "loop :: IO ()" + , "loop = loop" + ]) + +testManyTimes :: TestSuiteEnv -> Assertion +testManyTimes env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + replicateM_ 100 $ do + runActions <- runStmt session "Main" "main" + interrupt runActions + (_output, result) <- runWaitAll runActions + assertBool ("Expected asynchronous exception; got " ++ show result) (isAsyncException result) + + runActions <- runStmt session "Main" "main" + supplyStdin runActions "\n" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Hi!\n" output + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "Main.hs" "main = putStrLn \"Hi!\" >> getLine >> return ()") + <> (updateStdoutBufferMode (RunLineBuffering Nothing)) diff --git a/TestSuite/TestSuite/Tests/Issues.hs b/TestSuite/TestSuite/Tests/Issues.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/Issues.hs @@ -0,0 +1,632 @@ +-- Tests for specific issues +{-# LANGUAGE CPP #-} +module TestSuite.Tests.Issues (testGroupIssues) where + +import Prelude hiding (span, mod) +import Control.Concurrent +import Control.Exception (bracket) +import Control.Monad +import Data.List (isInfixOf) +import Data.Monoid +import System.Exit +import System.FilePath +import System.Process +import System.Timeout +import Test.HUnit +import Test.Tasty +import qualified Data.ByteString.Lazy as L hiding (all) +import qualified Data.ByteString.Lazy.Char8 as L (unlines, all) +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.Text as T + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupIssues :: TestSuiteEnv -> TestTree +testGroupIssues env = testGroup "Issues" $ [ + withOK env " #32: Paths in type errors" test32 + , stdTest env " #94: Quickfix for Updating static files never triggers --- illegal var name" test94_illegalVarName + , stdTest env " #94: Quickfix for Updating static files never triggers --- missing file" test94_missingFile + , stdTest env " #94: Quickfix for Updating static files never triggers recompilation" test94 + , stdTest env "#115: Dynamically setting/unsetting -Werror" test115 + , stdTest env "#118: ghc qAddDependentFile patch" test118 + , stdTest env "#125: Hang when snippet calls createProcess with close_fds set to True" test125 + , stdTest env "#134: Updating dependent data files multiple times per second" test134 + , stdTest env "#145: GHC bug #8333" test145 + , stdTest env "#169: Data files should not leak into compilation if referenced" test169 + , stdTest env "#170: GHC API expects 'main' to be present in 'Main'" test170_GHC + , stdTest env "#185: Invalid GHC option and option warnings" test185 + , stdTest env "#191: Limit stack size (#191)" test191 + , withOK env "#194: Start server without bracket (need MANUAL check that server will die)" test194 + , stdTest env "#213: Missing location information" test213 + , stdTest env "#214: Changing linker flags" test214 + , stdTest env "#219: runStmt gets corrupted by async exceptions" test219 + , stdTest env "#220: Calling forceCancel can have detrimental side-effects" test220 + , stdTest env "#224: Package flags are not reset correctly" test224 + , stdTest env "#229: Client library does not detect snippet server crash" test229 + ] ++ exeTests env [ + stdTest env "#119: Re-building an executable after a code change does not rebuild" test119 + , stdTest env "#169: Data files should not leak in exe building" test169_buildExe + , stdTest env "#169: Data files should not leak in exe building, with a extra modules" test169_buildExe_extraModules + , stdTest env "#169: Data files should not leak in exe building, with a non-'Main' main module" test169_buildExe_nonMain + , stdTest env "#170: buildExe doesn't expect 'Main.main' to be present nor to be in IO" test170_buildExe + ] + +test119 :: TestSuiteEnv -> Assertion +test119 env = withAvailableSession env $ \session -> do + distDir <- getDistDir session + + let cb = \_ -> return () + update = flip (updateSession session) cb + + update $ updateCodeGeneration True + update $ updateStdoutBufferMode (RunLineBuffering Nothing) + update $ updateStderrBufferMode (RunLineBuffering Nothing) + + -- Compile code and execute + + update $ updateSourceFile "src/Main.hs" "main = putStrLn \"Version 1\"" + assertNoErrors session + + update $ buildExe [] [(T.pack "Main", "src/Main.hs")] + out1 <- readProcess (distDir "build" "Main" "Main") [] [] + assertEqual "" "Version 1\n" out1 + runActionsExe <- runExe session "Main" + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "Version 1\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + + -- Update the code and execute again + + update $ updateSourceFile "src/Main.hs" "main = putStrLn \"Version 2\"" + assertNoErrors session + + update $ buildExe [] [(T.pack "Main", "src/Main.hs")] + out2 <- readProcess (distDir "build" "Main" "Main") [] [] + assertEqual "" "Version 2\n" out2 + runActionsExe2 <- runExe session "Main" + (outExe2, statusExe2) <- runWaitAll runActionsExe2 + assertEqual "Output from runExe" + "Version 2\n" + outExe2 + assertEqual "after runExe" ExitSuccess statusExe2 + +test125 :: TestSuiteEnv -> Assertion +test125 env = withAvailableSession env $ \session -> do + let cb = \_ -> return () + update = flip (updateSession session) cb + + update $ updateCodeGeneration True + update $ updateStdoutBufferMode (RunLineBuffering Nothing) + update $ updateStderrBufferMode (RunLineBuffering Nothing) + update $ updateGhcOpts ["-Wall", "-Werror"] + + update $ updateSourceFile "src/Main.hs" $ L.unlines [ + "module Main where" + + , "import System.Process" + , "import System.IO" + + , "main :: IO ()" + , "main = do" + , " (_,Just maybeOut,_,pr) <- createProcess $ (shell \"foo\")" + , " { cmdspec = ShellCommand \"echo 123\"" + , " , cwd = Nothing" + , " , env = Nothing" + , " , std_in = CreatePipe" + , " , std_out = CreatePipe" + , " , std_err = CreatePipe" + , " , close_fds = True" + , " , create_group = False" + , " }" + , " putStr =<< hGetContents maybeOut" + , " terminateProcess pr" + ] + + assertNoErrors session + mRunActions <- timeout 2000000 $ runStmt session "Main" "main" + case mRunActions of + Just runActions -> do + mRunResult <- timeout 2000000 $ runWaitAll runActions + case mRunResult of + Just (output, RunOk) -> assertEqual "" "123\n" output + Nothing -> assertFailure "Timeout in runWaitAll" + _ -> assertFailure "Unexpected run result" + Nothing -> + assertFailure "Timeout in runStmt" + +test118 :: TestSuiteEnv -> Assertion +test118 env = withAvailableSession env $ \session -> do + let cb = \_ -> return () + update = flip (updateSession session) cb + + update $ mconcat + [ updateSourceFile "Main.hs" mainContents + , updateDataFile "foo.hamlet" "invalid" + ] + + -- Error message expected, invalid data file + assertOneError session + + update $ updateDataFile "foo.hamlet" "42" + assertNoErrors session + + update $ updateSourceFile "Main.hs" $ mainContents `L.append` "\n\n-- Trigger a recompile" + assertNoErrors session + + update $ updateDataFile "foo.hamlet" "invalid" + assertOneError session + where + mainContents = L.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "import Language.Haskell.TH.Syntax" + , "main = print ($(do" + , " qAddDependentFile \"foo.hamlet\"" + , " s <- qRunIO $ readFile \"foo.hamlet\"" + , " lift $ (read s :: Int)" + , " ) :: Int)" + ] + +test32 :: TestSuiteEnv -> IO String +test32 env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + errs <- getSourceErrors session + let none p = all (not . p) + let containsFullPath e = + "session." `isInfixOf` T.unpack (errorMsg e) + fixme session "#32" $ assertBool "" (none containsFullPath errs) + where + upd = (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "f x = show . read" + ]) + +test134 :: TestSuiteEnv -> Assertion +test134 env = withAvailableSession env $ \session -> do + let cb = \_ -> return () + update = flip (updateSession session) cb + str i = L.fromString $ show (i :: Int) ++ "\n" + + update $ mconcat + [ updateSourceFile "Main.hs" mainContents + , updateDataFile "foo.hamlet" (str 1) + , updateCodeGeneration True + ] + assertNoErrors session + + do runActions <- runStmt session "Main" "main" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" (str 1) output + + forM_ [2 .. 99] $ \i -> do + update $ updateDataFile "foo.hamlet" (str i) + runActions <- runStmt session "Main" "main" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" (str i) output + where + mainContents = L.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "import Language.Haskell.TH.Syntax" + , "main = print ($(do" + , " qAddDependentFile \"foo.hamlet\"" + , " s <- qRunIO $ readFile \"foo.hamlet\"" + , " lift $ (read s :: Int)" + , " ) :: Int)" + ] + +test115 :: TestSuiteEnv -> Assertion +test115 env = withAvailableSession env $ \session -> do + updateSessionD session upd1 1 + errs1 <- getSourceErrors session + unless (any (== KindError) $ map errorKind errs1) $ + assertFailure $ "Expected some errors in " ++ show3errors errs1 + + updateSessionD session upd2 1 + errs2 <- getSourceErrors session + when (any (== KindError) $ map errorKind errs2) $ + assertFailure $ "Expected only warnings in " ++ show3errors errs2 + where + upd1 = (updateGhcOpts ["-Wall", "-Werror"]) + <> (updateSourceFile "src/Main.hs" $ L.unlines [ + "module Main where" + , "main = putStrLn \"Hello 1\"" + ]) + + upd2 = (updateGhcOpts ["-Wall"]) + <> (updateSourceFile "src/Main.hs" $ L.unlines [ + "module Main where" + , "main = putStrLn \"Hello 2\"" + ]) + +test185 :: TestSuiteEnv -> Assertion +test185 env = withAvailableSession env $ \session -> do + updateSessionD session upd 0 + errs <- getSourceErrors session + -- We expect two warnings (one deprecated, one unrecognized) + assertEqual "" 2 (length errs) + where + upd = updateGhcOpts ["-fglasgow-exts","-thisOptionDoesNotExist"] + +test145 :: TestSuiteEnv -> IO () +test145 env = withAvailableSession env $ \session -> do + -- Setting -O is officially no longer supported from 7.10 and up + -- See + if testSuiteEnvGhcVersion env >= GHC_7_10 + then skipTest "-O no longer supported" + else do + updateSessionD session upd1 1 + assertNoErrors session + where + upd1 = (updateCodeGeneration True) + <> (updateGhcOpts ["-XScopedTypeVariables", "-O"]) + <> (updateSourceFile "Main.hs" "main = let (x :: String) = \"hello\" in putStrLn x") + +test170_GHC :: TestSuiteEnv -> Assertion +test170_GHC env = withAvailableSession env $ \session -> do + updateSessionD session update 2 + assertOneError session + where + update = updateDataFile "Data/Monoid.hs" "module Data.Monoid where\nfoo = doesnotexist" + <> updateSourceFile "Main.hs" "module Main where\nimport Data.Monoid\nmain2222 = return ()" + +test170_buildExe :: TestSuiteEnv -> Assertion +test170_buildExe env = withAvailableSession env $ \session -> do + updateSessionD session update 2 + assertNoErrors session + let updE = buildExe [] [(T.pack "Main", "Main.hs")] + updateSessionD session updE 1 + status <- getBuildExeStatus session + assertEqual "buildExe doesn't know 'main' is in IO" + (Just $ ExitFailure 1) status + where + update = updateDataFile "Data/Monoid.hs" "module Data.Monoid where\nfoo = doesnotexist" + <> updateSourceFile "Main.hs" "module Main where\nimport Data.Monoid\nmain = return ()" + +test169 :: TestSuiteEnv -> Assertion +test169 env = withAvailableSession env $ \session -> do + updateSessionD session update 2 + assertNoErrors session + where + update = updateDataFile "Data/Monoid.hs" "module Data.Monoid where\nfoo = doesnotexist" + <> updateSourceFile "Main.hs" "module Main where\nimport Data.Monoid\nmain = return ()" + +test169_buildExe :: TestSuiteEnv -> Assertion +test169_buildExe env = withAvailableSession env $ \session -> do + updateSessionD session update 2 + assertNoErrors session + let updE = buildExe [] [(T.pack "Main", "Main.hs")] + updateSessionD session updE 2 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "" "" buildStderr + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + + let updDoc = buildDoc + updateSessionD session updDoc 1 + statusDoc <- getBuildDocStatus session + assertEqual "after doc build" (Just ExitSuccess) statusDoc + where + update = updateDataFile "Data/Monoid.hs" "module Data.Monoid where\nfoo = doesnotexist" + <> updateSourceFile "Main.hs" "module Main where\nimport Data.Monoid\nmain :: IO()\nmain = return ()" + +test169_buildExe_extraModules :: TestSuiteEnv -> Assertion +test169_buildExe_extraModules env = withAvailableSession env $ \session -> do + updateSessionD session update 4 + assertNoErrors session + let updE = buildExe [] [(T.pack "Main", "Main.hs")] + updateSessionD session updE 4 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "" "" buildStderr + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + + let updDoc = buildDoc + updateSessionD session updDoc 1 + statusDoc <- getBuildDocStatus session + assertEqual "after doc build" (Just ExitSuccess) statusDoc + where + update = updateDataFile "Data/Monoid.hs" "module Data.Monoid where\nfoo = doesnotexist" + <> updateSourceFile "Main.hs" "module Main where\nimport Data.Monoid\nmain :: IO()\nmain = return ()" + <> updateSourceFile "NonMain.hs" "module NonMain where\nimport Data.Monoid\nmain :: IO()\nmain = return ()" + <> updateSourceFile "NonMain2.hs" "module NonMain2 where\nimport Data.Monoid\nmain :: IO()\nmain = return ()" + +test169_buildExe_nonMain :: TestSuiteEnv -> Assertion +test169_buildExe_nonMain env = withAvailableSession env $ \session -> do + updateSessionD session update 4 + assertNoErrors session + let updE = buildExe [] [(T.pack "NonMain", "NonMain.hs")] + updateSessionD session updE 4 + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "" "" buildStderr + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + + let updDoc = buildDoc + updateSessionD session updDoc 1 + statusDoc <- getBuildDocStatus session + assertEqual "after doc build" (Just ExitSuccess) statusDoc + where + update = updateDataFile "Data/Monoid.hs" "module Data.Monoid where\nfoo = doesnotexist" + <> updateSourceFile "Main.hs" "module Main where\nimport Data.Monoid\nmain :: IO()\nmain = return ()" + <> updateSourceFile "NonMain.hs" "module NonMain where\nimport Data.Monoid\nmain :: IO()\nmain = return ()" + <> updateSourceFile "NonMain2.hs" "module NonMain2 where\nimport Data.Monoid\nmain :: IO()\nmain = return ()" + +test194 :: TestSuiteEnv -> IO String +test194 env = do + _session <- startNewSession (defaultServerConfig env) + threadDelay 2000000 + -- TODO: Add process ID in OK message + return "PLEASE VERIFY THAT SERVER HAS TERMINATED" + +test213 :: TestSuiteEnv -> Assertion +test213 env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + version <- getGhcVersion session + if version < GHC_7_8 + then + -- 7.4.2 just reports the first module error + assertSourceErrors session [ + [(Just "Main.hs", "Could not find module")] + ] + else + -- 7.8 and up report both; make sure we have location info (#213) + assertSourceErrors session [ + [(Just "Main.hs", "Could not find module")] + , [(Just "Main.hs", "Could not find module")] + ] + where + upd = updateSourceFile "Main.hs" $ L.unlines + [ "import DoesNotExist1" + , "import DoesNotExist2" + ] + +test214 :: TestSuiteEnv -> Assertion +test214 env = withAvailableSession env $ \session -> do + updateSessionD session setup 0 + + -- Try to load without enabling -lz. Will fail + updateSessionD session source 2 + assertSomeErrors session + + -- Now set the -lz option, and try again. Should succeed now. + updateSessionD session linkLz 2 + assertNoErrors session + + -- Actually run the code, just to be sure linking worked properly + runActions <- runStmt session "Main" "print_zlib_version" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + -- We're not really sure what version to expect; but it should probably look + -- like a version anyway :) + assertBool ("unexpected version " ++ show output) (isVersion output) + where + setup, source, linkLz :: IdeSessionUpdate + setup = updateCodeGeneration True + linkLz = updateGhcOpts ["-lz"] + source = updateSourceFile "Main.hs" "foreign import ccall \"print_zlib_version\" print_zlib_version :: IO ()" + <> updateSourceFile "foo.c" (L.unlines + [ "#include " + , "#include " + , "void print_zlib_version() {" + , " fputs(zlibVersion(), stderr);" + , "}" + ]) + + isVersion :: L.ByteString -> Bool + isVersion = L.all (`elem` ('.' : ['0'..'9'])) + +test219 :: TestSuiteEnv -> Assertion +test219 env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + _ <- timeout 1 $ + bracket (runStmt session "Main" "main") + (forceCancel) + (\_ -> return ()) + + runActions <- runStmt session "Main" "main" + (_output, result) <- runWaitAll runActions + assertEqual "" RunOk result + where + upd = updateSourceFile "Main.hs" "main = return ()" + <> updateCodeGeneration True + +test220 :: TestSuiteEnv -> Assertion +test220 env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + replicateM_ 100 $ do + runActions <- runStmt session "Main" "main" + (_output, result) <- runWaitAll runActions + assertEqual "" RunOk result + forceCancel runActions + where + upd = updateSourceFile "Main.hs" "main = return ()" + <> updateCodeGeneration True + +test94 :: TestSuiteEnv -> Assertion +test94 env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertOneError session + + updateSessionD session upd2 1 + assertNoErrors session + where + upd = updateDataFile "A.foo" "unboundVarName" + <> (updateSourceFile "A.hs" . L.unlines $ + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A where" + , "import Language.Haskell.TH.Syntax" + , "goodVarName = 42" + , "foo :: Int" + , "foo = $(do" + , " qAddDependentFile \"A.foo\"" + , " s <- qRunIO (readFile \"A.foo\")" + , " return $ VarE (mkName s))" + ]) + + upd2 = updateDataFile "A.foo" "goodVarName" + +test94_illegalVarName :: TestSuiteEnv -> Assertion +test94_illegalVarName env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertOneError session + + updateSessionD session upd2 1 + assertNoErrors session + where + upd = updateDataFile "A.foo" "42 is a wrong var name" + <> (updateSourceFile "A.hs" . L.unlines $ + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A where" + , "import Language.Haskell.TH.Syntax" + , "goodVarName = 42" + , "foo :: Int" + , "foo = $(do" + , " qAddDependentFile \"A.foo\"" + , " s <- qRunIO (readFile \"A.foo\")" + , " return $ VarE (mkName s))" + ]) + + upd2 = updateDataFile "A.foo" "goodVarName" + +test94_missingFile :: TestSuiteEnv -> Assertion +test94_missingFile env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertOneError session + + updateSessionD session upd2 1 + assertNoErrors session + where + upd = (updateSourceFile "A.hs" . L.unlines $ + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A where" + , "import Language.Haskell.TH.Syntax" + , "foo :: String" + , "foo = $(do" + , " qAddDependentFile \"A.foo\"" + , " x <- qRunIO (readFile \"A.foo\")" + , " lift x)" + ]) + + upd2 = updateDataFile "A.foo" "fooString" + +test224 :: TestSuiteEnv -> Assertion +test224 env = withAvailableSession env $ \session -> do + do updateSessionD session upd1 1 + assertNoErrors session + + runActions <- runStmt session "Main" "main" + result <- runWaitAll runActions + assertEqual "" ("Hi 1\n", RunOk) result + + do updateSessionD session upd2 1 + assertNoErrors session + + runActions <- runStmt session "Main" "main" + result <- runWaitAll runActions + assertEqual "" ("Hi 2\n", RunOk) result + where + upd1 = updateGhcOpts ["-hide-all-packages", "-package base"] + <> updateCodeGeneration True + <> updateSourceFile "Main.hs" "main = putStrLn \"Hi 1\"" + + upd2 = updateGhcOpts [] + <> updateCodeGeneration True + <> updateSourceFile "Main.hs" "main = putStrLn \"Hi 2\"" + +test229 :: TestSuiteEnv -> Assertion +#if defined(darwin_HOST_OS) +test229 env = withAvailableSession env $ \_session -> do + skipTest "Known failure on OSX" +#else +test229 env = withAvailableSession env $ \session -> do + updateSessionD session upd 2 + assertNoErrors session + + runActions <- runStmt session "Main" "crash" + (_output, result) <- runWaitAll runActions + case result of + RunGhcException _ -> return () + _ -> assertFailure $ "Unexpected run result " ++ show result + where + upd :: IdeSessionUpdate + upd = updateCodeGeneration True + <> updateSourceFile "Main.hs" "foreign import ccall \"crash\" crash :: IO ()" + <> updateSourceFile "foo.c" (L.unlines + [ "#include " + , "void crash() {" + , " char *p = NULL;" + , " *p = '!';" + , " printf(\"We won't get this far\\n\");" + , "}" + ]) +#endif + +test191 :: TestSuiteEnv -> Assertion +test191 env = withAvailableSession env $ \session -> do + when (testSuiteEnvGhcVersion env == GHC_7_4) $ + skipTest "Known failure on 7.4.2 (#191)" + + updateSessionD session upd 1 + assertNoErrors session + + -- In the default session stack limit is 8M. test1 should fail: + do runActions <- runStmt session "Main" "test1" + (_output, result) <- runWaitAll runActions + case result of + RunProgException _ -> return () + _ -> assertFailure $ "Unexpected run result " ++ show result + + -- But test2 should work: + do runActions <- runStmt session "Main" "test2" + (_output, result) <- runWaitAll runActions + case result of + RunOk -> return () + _ -> assertFailure $ "Unexpected run result " ++ show result + + -- But after we change the stack size, test2 too will crash: + -- (Note that we cannot set this value _too_ low otherwise the main server + -- itself, rather than the snippet, will crash. See Issue #266.) + updateSessionD session (updateRtsOpts ["-K256K"]) 1 + do runActions <- runStmt session "Main" "test2" + (_output, result) <- runWaitAll runActions + case result of + RunProgException _ -> return () + _ -> assertFailure $ "Unexpected run result " ++ show result + + -- But test3 will still work: + do runActions <- runStmt session "Main" "test3" + (_output, result) <- runWaitAll runActions + case result of + RunOk -> return () + _ -> assertFailure $ "Unexpected run result " ++ show result + where + upd :: IdeSessionUpdate + upd = updateCodeGeneration True + <> (updateSourceFile "Main.hs" $ L.unlines [ + "overflow :: Int -> IO Int" + , "overflow n = do" + , " n' <- overflow (n + 1)" + , " return (n + n')" + , "" + , "test1 :: IO ()" + , "test1 = print =<< overflow 0" + , "" + , "test2 :: IO ()" + , "test2 = print $ foldl (+) 0 [1..100000]" + , "" + , "test3 :: IO ()" + , "test3 = print (1 :: Int)" + ]) diff --git a/TestSuite/TestSuite/Tests/Packages.hs b/TestSuite/TestSuite/Tests/Packages.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/Packages.hs @@ -0,0 +1,561 @@ +module TestSuite.Tests.Packages (testGroupPackages) where + +import Prelude hiding (span, mod) +import Data.Maybe +import Data.Monoid +import System.Exit +import System.Process +import System.FilePath +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.ByteString.Lazy.Char8 as L (unlines) +import qualified Data.Text as T + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupPackages :: TestSuiteEnv -> TestTree +testGroupPackages env = testGroup "Packages" $ [ + stdTest env "Package dependencies" test_PackageDependencies + , stdTest env "Register a package, don't restart session, don't see the package" test_Register_NoRestart + , stdTest env "Register a package, restart session, see the package and check for cabal macros" test_Register_Restart + , stdTest env "Make sure package DB is passed to ghc (configGenerateModInfo False)" test_PackageDB_ModInfoFalse + , stdTest env "Make sure package DB is passed to ghc (configGenerateModInfo True)" test_PackageDB_ModInfoTrue + , stdTest env "Make sure package DB is passed to ghc after restartSession" test_PackageDB_AfterRestart + , stdTest env "Module name visible from 2 packages --- picked from mtl (expected failure)" test_ModuleIn2Pkgs_2 + , stdTest env "Hiding and unhiding a package (#185-2)" test_HideUnhide + , stdTest env "Unhiding and hiding a package (#185-3; converse of #185-2)" test_UnhideHide + , stdTest env "Trusting and distrusting packages (#185-4)" test_TrustDistrust + , stdTest env "Using something from a different package (no \"Loading package\" msg)" test_UseFromDifferentPackage + ] ++ docTests env [ + stdTest env "Consistency of multiple modules of the same name" test_Consistency + , withOK env "Consistency of multiple modules of the same name: PackageImports" test_Consistency_PackageImports + , stdTest env "Module name visible from 2 packages --- picked from monads-tf" test_ModuleIn2Pkgs_1 + ] + +test_PackageDependencies :: TestSuiteEnv -> Assertion +test_PackageDependencies env = withAvailableSession' env (withGhcOpts ["-hide-package monads-tf"]) $ \session -> do + updateSessionD session upd 3 + assertNoErrors session + + deps <- getPkgDeps session + assertEqual "" (ignoreVersions "Just [base-4.5.1.0,ghc-prim-0.2.0.0,integer-gmp-0.4.0.0]") (ignoreVersions $ show (deps "A")) + assertEqual "" (ignoreVersions "Just [parallel-3.2.0.4,base-4.5.1.0,ghc-prim-0.2.0.0,integer-gmp-0.4.0.0]") (ignoreVersions $ show (deps "B")) + assertEqual "" (ignoreVersions "Just [mtl-2.1.2,base-4.5.1.0,ghc-prim-0.2.0.0,integer-gmp-0.4.0.0,transformers-0.3.0.0]") (ignoreVersions $ show (deps "C")) + where + upd = (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + ]) + <> (updateSourceFile "B.hs" . L.unlines $ + [ "module B where" + , "import Control.Parallel" + ]) + <> (updateSourceFile "C.hs" . L.unlines $ + [ "module C where" + , "import Control.Monad.Cont" -- from mtl + ]) + +test_Register_NoRestart :: TestSuiteEnv -> Assertion +test_Register_NoRestart env = withAvailableSession env $ \session -> do + -- Session is started successfully, because we haven't referenced the + -- package yet. + + withInstalledPackage env "TestSuite/inputs/simple-lib17" $ do + -- Package is now installed, but the session not restarted, so we cannot + -- reference the new package + updateSessionD session upd 1 + assertSomeErrors session + where + upd = updateGhcOpts ["-package simple-lib17"] + <> (updateSourceFile "Main.hs" . L.unlines $ + [ "module Main where" + , "import SimpleLib (simpleLib)" + , "main = print simpleLib" + ]) + +test_Register_Restart :: TestSuiteEnv -> Assertion +test_Register_Restart env = withAvailableSession env $ \session -> do + -- Session is started successfully, because we haven't referenced the + -- package yet. + + withInstalledPackage env "TestSuite/inputs/simple-lib17" $ do + -- After restarting the session the new package should be visible + restartSession session + updateSessionD session upd 1 + assertNoErrors session + + ifTestingExe env $ do + let m = "Main" + upd2 = buildExe [] [(T.pack m, "Main.hs")] + updateSessionD session upd2 2 + distDir <- getDistDir session + out <- readProcess (distDir "build" m m) [] [] + assertEqual "DB exe output" + "42\n" + out + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "42\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + + where + upd = updateGhcOpts ["-package simple-lib17", "-XCPP"] + <> (updateSourceFile "Main.hs" . L.unlines $ + [ "module Main where" + , "import SimpleLib (simpleLib)" + , "#if MIN_VERSION_simple_lib17(0,1,0)" + , "main = print simpleLib" + , "#else" + , "terrible error" + , "#endif" + ]) + +test_PackageDB_ModInfoFalse :: TestSuiteEnv -> Assertion +test_PackageDB_ModInfoFalse env = withAvailableSession' env setup $ \session -> do + -- We expect an error because 'ide-backend-rts' and/or 'parallel' + -- are not (usually?) installed in the global package DB. + updateSessionD session upd 1 + assertSourceErrors session [[ + (Nothing, expected1) + , (Nothing, expected2) + ]] + where + packageOpts = ["-package parallel"] + setup = withModInfo True + . withDBStack [GlobalPackageDB] + . withGhcOpts packageOpts + + upd = (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "import Control.Parallel" + ]) + + expected1 = "cannot satisfy -package ide-backend-rts" + expected2 = "cannot satisfy -package parallel" + +test_PackageDB_ModInfoTrue :: TestSuiteEnv -> Assertion +test_PackageDB_ModInfoTrue env = withAvailableSession' env setup $ \session -> do + -- We expect an error because 'ide-backend-rts' and/or 'parallel' + -- are not (usually?) installed in the global package DB. + updateSessionD session upd 1 + assertSourceErrors session [[ + (Nothing, expected1) + , (Nothing, expected2) + ]] + where + packageOpts = ["-package parallel"] + setup = withModInfo True + . withDBStack [GlobalPackageDB] + . withGhcOpts packageOpts + + upd = (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "import Control.Parallel" + ]) + + expected1 = "cannot satisfy -package ide-backend-rts" + expected2 = ": cannot satisfy -package parallel" + +test_PackageDB_AfterRestart :: TestSuiteEnv -> Assertion +test_PackageDB_AfterRestart env = withAvailableSession' env setup $ \session -> do + restartSession session + -- We expect an error because 'ide-backend-rts' and/or 'parallel' + -- are not (usually?) installed in the global package DB. + updateSessionD session upd 1 + assertSourceErrors session [[ + (Nothing, expected1) + , (Nothing, expected2) + ]] + where + packageOpts = ["-package parallel"] + setup = withModInfo True + . withDBStack [GlobalPackageDB] + . withGhcOpts packageOpts + + upd = (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "import Control.Parallel" + ]) + + expected1 = "cannot satisfy -package ide-backend-rts" + expected2 = ": cannot satisfy -package parallel" + +{- +18:45 < mikolaj> from http://www.haskell.org/ghc/docs/7.4.2/html/users_guide/packages.html#package-overlaps +18:45 < mikolaj> It is possible that by using packages you might end up with a program that contains two modules with the same name: perhaps you used a package P that has a hidden module M, and there is also a module M in your program. + Or perhaps the dependencies of packages that you used contain some overlapping modules. Perhaps the program even contains multiple versions of a certain package, due to dependencies from other packages. +18:45 < mikolaj> None of these scenarios gives rise to an error on its own[8], but they may have some interesting consequences. For instance, if you have a type M.T from version 1 of package P, then this is not the same as the type M.T + from version 2 of package P, and GHC will report an error if you try to use one where the other is expected. +18:46 < mikolaj> so it seems it's unspecified which module will be used --- it just happens that our idInfo code picks a different package than GHC API in this case +-} +test_Consistency :: TestSuiteEnv -> Assertion +test_Consistency env = withAvailableSession env $ \sess -> do + let cb = \_ -> return () + update = flip (updateSession sess) cb + updMod = \mod code -> updateSourceFile mod (L.fromString code) + + update $ updMod "Control/Parallel.hs" $ unlines [ + "module Control.Parallel where" + , "" + , "import Bar" + , "" + , "foo = bar >> bar" + , "" + , "foobar = putStrLn \"Baz\"" + ] + + update $ updMod "Bar.hs" $ unlines [ + "module Bar where" + , "" + , "bar = putStrLn \"Hello, world!\"" + ] + + update $ updMod "Baz.hs" $ unlines [ + "module Baz where" + , "" + , "import Control.Parallel" + , "import Bar" + , "" + , "baz = foobar" + ] + + assertNoErrors sess + assertIdInfo sess "Bar" (3, 7, 3, 15) "putStrLn" VarName "String -> IO ()" "base-4.5.1.0:System.IO" "" "base-4.5.1.0:System.IO" "imported from base-4.5.1.0:Prelude at Bar.hs@1:8-1:11" +-- w fail: assertIdInfo gif "Baz" (6, 8, 6, 9) "foobar" VarName "IO ()" "main:Control.Parallel" "Control/Parallel.hs@7:1-7:7" "" "imported from main:Control.Parallel at Baz.hs@3:1-3:24" + + update $ updMod "Baz.hs" $ unlines [ + "module Baz where" + , "" + , "import Control.Parallel" + , "import Bar" + , "" + , "baz = foobar >>>> foo >> bar" + ] + assertOneError sess + _ <- getSpanInfo sess -- TODO: Is this call useful? + assertIdInfo sess "Bar" (3, 7, 3, 15) "putStrLn" VarName "String -> IO ()" "base-4.5.1.0:System.IO" "" "base-4.5.1.0:System.IO" "imported from base-4.5.1.0:Prelude at Bar.hs@1:8-1:11" + -- Baz is broken at this point + + update $ updMod "Baz.hs" $ unlines [ + "module Baz where" + , "" + , "import Control.Parallel" + , "import Bar" + , "" + , "baz = foobar >> foo >> bar" + ] + + assertNoErrors sess + assertIdInfo sess "Bar" (3, 7, 3, 15) "putStrLn" VarName "String -> IO ()" "base-4.5.1.0:System.IO" "" "base-4.5.1.0:System.IO" "imported from base-4.5.1.0:Prelude at Bar.hs@1:8-1:11" +-- would fail: assertIdInfo gif "Baz" (6, 8, 6, 9) "foobar" VarName "IO ()" "main:Control.Parallel" "Control/Parallel.hs@7:1-7:7" "" "imported from main:Control/Parallel at Baz.hs@3:1-3:24" + +test_Consistency_PackageImports :: TestSuiteEnv -> IO String +test_Consistency_PackageImports env = withAvailableSession env $ \sess -> do + let cb = \_ -> return () + update = flip (updateSession sess) cb + updMod = \mod code -> updateSourceFile mod (L.fromString code) + + update $ updMod "Control/Parallel.hs" $ unlines [ + "module Control.Parallel where" + , "" + , "import Bar" + , "" + , "foo = bar >> bar" + , "" + , "par = putStrLn \"Baz\"" + ] + + update $ updMod "Bar.hs" $ unlines [ + "module Bar where" + , "" + , "bar = putStrLn \"Hello, world!\"" + ] + + update $ updMod "Baz.hs" $ unlines [ + "{-# LANGUAGE PackageImports #-}" + , "module Baz where" + , "" + , "import \"parallel\" Control.Parallel" + , "import Bar" + , "" + , "baz = par" + ] + + assertNoErrors sess + assertIdInfo sess "Bar" (3, 7, 3, 15) "putStrLn" VarName "String -> IO ()" "base-4.5.1.0:System.IO" "" "base-4.5.1.0:System.IO" "imported from base-4.5.1.0:Prelude at Bar.hs@1:8-1:11" + fixme sess "#254" $ assertIdInfo sess "Baz" (7, 7, 7, 10) "par" VarName "a1 -> b1 -> b1" "parallel-X.Y.Z:Control.Parallel" "" "parallel-X.Y.Z:Control.Parallel" "imported from parallel-X.Y.Z:Control.Parallel at Baz.hs@4:1-4:35" + +test_ModuleIn2Pkgs_1 :: TestSuiteEnv -> Assertion +test_ModuleIn2Pkgs_1 env = withAvailableSession' env (withGhcOpts packageOpts) $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + imports <- getImports session + let base mod = ModuleId { + moduleName = T.pack mod + , modulePackage = PackageId { + packageName = "base" + , packageVersion = Just "X.Y.Z" + , packageKey = "base" -- ignoreVersions sets key == name + } + } + monads_tf mod = ModuleId { + moduleName = T.pack mod + , modulePackage = PackageId { + packageName = "monads-tf" + , packageVersion = Just "X.Y.Z" + , packageKey = "monads-tf" + } + } + assertSameSet "imports: " (ignoreVersions . fromJust . imports $ "A") $ [ + Import { + importModule = base "Prelude" + , importPackage = Nothing + , importQualified = False + , importImplicit = True + , importAs = Nothing + , importEntities = ImportAll + } + , Import { + importModule = monads_tf "Control.Monad.Cont" + , importPackage = Just "monads-tf" + , importQualified = False + , importImplicit = False + , importAs = Nothing + , importEntities = ImportAll + } + ] + + -- TODO: We expect the scope "imported from monads-tf-X.Y.Z:Control.Monad.Cont at A.hs@3:1-3:38" + -- but we cannot guarantee it (#95) + assertIdInfo' session "A" (4,5,4,12) (4,5,4,12) "runCont" VarName (allVersions "Cont r1 a1 -> (a1 -> r1) -> r1") (allVersions "transformers-X.Y.Z:Control.Monad.Trans.Cont") (allVersions "") (allVersions "monads-tf-X.Y.Z:Control.Monad.Cont") [] + where + packageOpts = [ "-hide-all-packages" + , "-package base" + , "-package monads-tf" + , "-package mtl" + ] + + upd = (updateSourceFile "A.hs" . L.unlines $ + [ "{-# LANGUAGE PackageImports #-}" + , "module A where" + , "import \"monads-tf\" Control.Monad.Cont" + , "f = runCont" + ]) + +test_ModuleIn2Pkgs_2 :: TestSuiteEnv -> Assertion +test_ModuleIn2Pkgs_2 env = withAvailableSession' env (withGhcOpts packageOpts) $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + imports <- getImports session + let base mod = ModuleId { + moduleName = T.pack mod + , modulePackage = PackageId { + packageName = "base" + , packageVersion = Just "X.Y.Z" + , packageKey = "base" -- ignoreVersions sets key == name + } + } + mtl mod = ModuleId { + moduleName = T.pack mod + , modulePackage = PackageId { + packageName = "mtl" + , packageVersion = Just "X.Y.Z" + , packageKey = "mtl" + } + } + assertSameSet "imports: " (ignoreVersions . fromJust . imports $ "A") $ [ + Import { + importModule = base "Prelude" + , importPackage = Nothing + , importQualified = False + , importImplicit = True + , importAs = Nothing + , importEntities = ImportAll + } + , Import { + importModule = mtl "Control.Monad.Cont" + , importPackage = Just "mtl" + , importQualified = False + , importImplicit = False + , importAs = Nothing + , importEntities = ImportAll + } + ] + + -- TODO: We expect the scope "imported from mtl-X.Y.Z:Control.Monad.Cont at A.hs@3:1-3:38" + -- but we cannot guarantee it (#95) + assertIdInfo' session "A" (4,5,4,12) (4,5,4,12) "runCont" VarName (allVersions "Cont r1 a1 -> (a1 -> r1) -> r1") (allVersions "transformers-X.Y.Z:Control.Monad.Trans.Cont") (allVersions "") (allVersions "mtl-X.Y.Z:Control.Monad.Cont") [] + where + packageOpts = [ "-hide-all-packages" + , "-package base" + , "-package monads-tf" + , "-package mtl" + ] + + upd = (updateSourceFile "A.hs" . L.unlines $ + [ "{-# LANGUAGE PackageImports #-}" + , "module A where" + , "import \"mtl\" Control.Monad.Cont" + , "f = runCont" + ]) + +-- We want to test that: +-- +-- 1. The package flags work at all +-- 2. Transitions +-- 3. Statelessness of updateGhcOpts +test_HideUnhide :: TestSuiteEnv -> Assertion +test_HideUnhide env = withAvailableSession env $ \session -> do + let runCode = do + runActions <- runStmt session "A" "test" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "9\n" output + + -- First, check that we can import stuff from the unix package + do let upd = (updateSourceFile "A.hs" $ L.unlines [ + "module A (test) where" + , "import System.Posix" + , "test :: IO ()" + , "test = print sigKILL" + ]) + <> (updateCodeGeneration True) + updateSessionD session upd 1 + assertNoErrors session + runCode + + -- Hide the package + do let upd = updateGhcOpts ["-hide-package unix"] + updateSessionD session upd 1 + assertOneError session + + -- Reveal the package again with an explicit flag + do let upd = updateGhcOpts ["-package unix"] + updateSessionD session upd 1 + assertNoErrors session + runCode + + -- Hide once more + do let upd = updateGhcOpts ["-hide-package unix"] + updateSessionD session upd 1 + assertOneError session + + -- Reveal it again by using the default package flags + -- (statelessness of updateGhcOpts) + do let upd = updateGhcOpts [] + updateSessionD session upd 1 + assertNoErrors session + runCode + +test_UnhideHide :: TestSuiteEnv -> Assertion +test_UnhideHide env = withAvailableSession env $ \session -> do + let runCode = do + runActions <- runStmt session "A" "test" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + case testSuiteEnvGhcVersion env of + GHC_7_4 -> assertEqual "" "7.4.\n" output + GHC_7_8 -> assertEqual "" "7.8.\n" output + GHC_7_10 -> assertEqual "" "7.10\n" output + + -- First, check that we cannot import from the ghc package + do let upd = (updateSourceFile "A.hs" $ L.unlines [ + "module A (test) where" + , "import Config" + , "test :: IO ()" + , "test = putStrLn (take 4 cProjectVersion)" + ]) + <> (updateCodeGeneration True) + updateSessionD session upd 1 + assertOneError session + + -- Reveal the package with an explicit flag + do let upd = updateGhcOpts ["-package ghc"] + updateSessionD session upd 1 + assertNoErrors session + runCode + + -- Hide the package + do let upd = updateGhcOpts ["-hide-package ghc"] + updateSessionD session upd 1 + assertOneError session + + -- Reveal once more + do let upd = updateGhcOpts ["-package ghc"] + updateSessionD session upd 1 + assertNoErrors session + runCode + + -- Hide it again by using the default package flags + -- (statelessness of updateGhcOpts) + do let upd = updateGhcOpts [] + updateSessionD session upd 1 + assertOneError session + +test_TrustDistrust :: TestSuiteEnv -> Assertion +test_TrustDistrust env = withAvailableSession env $ \session -> do + let runCode = do + runActions <- runStmt session "A" "test" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Hello\n" output + + -- First, check that base is untrusted + do let upd = (updateGhcOpts ["-XSafe", "-fpackage-trust"]) + <> (updateSourceFile "A.hs" $ L.unlines [ + "module A (test) where" + , "test :: IO ()" + , "test = putStrLn \"Hello\"" + ]) + <> (updateCodeGeneration True) + updateSessionD session upd 1 + assertOneError session + + -- Trust base + do let upd = updateGhcOpts ["-XSafe", "-fpackage-trust", "-trust base"] + updateSessionD session upd 1 + assertNoErrors session + runCode + + -- Untrust it + do let upd = updateGhcOpts ["-XSafe", "-fpackage-trust", "-distrust base"] + updateSessionD session upd 1 + assertOneError session + + -- Trust it once more + do let upd = updateGhcOpts ["-XSafe", "-fpackage-trust", "-trust base"] + updateSessionD session upd 1 + assertNoErrors session + runCode + + -- Untrust it again by using the default package flags + -- (statelessness of updateGhcOpts) + do let upd = updateGhcOpts ["-XSafe", "-fpackage-trust"] + updateSessionD session upd 1 + assertOneError session + +-- We pick something from the haskell platform but that doesn't come with ghc itself +-- https://github.com/haskell/haskell-platform/blob/2012.4.0.0/haskell-platform.cabal +test_UseFromDifferentPackage :: TestSuiteEnv -> Assertion +test_UseFromDifferentPackage env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "5\n" output + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import Control.Monad.IO.Class" -- From transformers + , "hello :: IO ()" + , "hello = liftIO $ print 5" + ]) diff --git a/TestSuite/TestSuite/Tests/Performance.hs b/TestSuite/TestSuite/Tests/Performance.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/Performance.hs @@ -0,0 +1,238 @@ +module TestSuite.Tests.Performance (testGroupPerformance) where + +import Prelude hiding (span) +import Control.Monad +import Data.Monoid +import System.IO.Unsafe (unsafePerformIO) +import System.Timeout +import Test.HUnit +import Test.Tasty +import qualified Control.Exception as Ex +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified System.Environment as System + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupPerformance :: TestSuiteEnv -> TestTree +testGroupPerformance env = testGroup "Performance" [ + stdTest env "Perf: Load testPerfMs modules in one call 1" test_OneCall_1 + , stdTest env "Perf: Load testPerfMs modules in one call 2" test_OneCall_2 + , stdTest env "Perf: Load testPerfMs modules in many calls 1" test_ManyCalls_1 + , stdTest env "Perf: Load testPerfMs modules in many calls 2" test_ManyCalls_2 + , stdTest env "Perf: Load 4xtestPerfMs modules, each batch in one call 1" test_Batch_OneCall_1 + , stdTest env "Perf: Load 4xtestPerfMs modules, each batch in one call 2" test_Batch_OneCall_2 + , stdTest env "Perf: Update a module testPerfTimes with no context 1" test_NoContext_1 + , stdTest env "Perf: Update a module testPerfTimes with no context 2" test_NoContext_2 + , stdTest env "Perf: Update a module testPerfTimes with testPerfMs modules 1" test_UpdateModule_1 + , stdTest env "Perf: Update a module testPerfTimes with testPerfMs modules 2" test_UpdateModule_2 + , stdTest env "Perf: Update and run a module testPerfTimes with testPerfMs modules 1" test_UpdateAndRun_1 + , stdTest env "Perf: Update and run a module testPerfTimes with testPerfMs modules 2" test_UpdateAndRun_2 + ] + +test_OneCall_1 :: TestSuiteEnv -> Assertion +test_OneCall_1 env = withAvailableSession env $ \session -> limitPerfTest $ do + updateSessionD session (updateCodeGeneration True) 1 + updateSessionD session updates testPerfMs + assertNoErrors session + where + updates = foldr (\n ups -> updKN n n <> ups) + mempty + [1..testPerfMs] + +test_OneCall_2 :: TestSuiteEnv -> Assertion +test_OneCall_2 env = withAvailableSession env $ \session -> limitPerfTest $ do + updateSessionD session (updateCodeGeneration True) 1 + updateSessionD session updates testPerfMs + assertNoErrors session + where + updates = foldr (\n ups -> updDepKN n n <> ups) + mempty + [1..testPerfMs] + +test_ManyCalls_1 :: TestSuiteEnv -> Assertion +test_ManyCalls_1 env = withAvailableSession env $ \session -> limitPerfTest $ do + updateSessionD session (updateCodeGeneration True) 1 + mapM_ (\up -> updateSessionD session up 1) updates + assertNoErrors session + where + updates = map (\n -> updKN n n) [1..testPerfMs] + +test_ManyCalls_2 :: TestSuiteEnv -> Assertion +test_ManyCalls_2 env = withAvailableSession env $ \session -> limitPerfTest $ do + updateSessionD session (updateCodeGeneration True) 1 + mapM_ (\up -> updateSessionD session up 1) updates + assertNoErrors session + where + updates = map (\n -> updDepKN n n) [1..testPerfMs] + +test_Batch_OneCall_1 :: TestSuiteEnv -> Assertion +test_Batch_OneCall_1 env = withAvailableSession env $ \session -> limitPerfTest $ do + updateSessionD session (updateCodeGeneration True) 1 + updateSessionD session updates1 testPerfMs + updateSessionD session updates2 testPerfMs + updateSessionD session updates1 testPerfMs + updateSessionD session updates2 testPerfMs + assertNoErrors session + where + updates1 = foldr (\n ups -> updKN n n <> ups) + mempty + [1..testPerfMs] + updates2 = foldr (\n ups -> updKN 42 n <> ups) + mempty + [1..testPerfMs] + +test_Batch_OneCall_2 :: TestSuiteEnv -> Assertion +test_Batch_OneCall_2 env = withAvailableSession env $ \session -> limitPerfTest $ do + updateSessionD session (updateCodeGeneration True) 1 + updateSessionD session updates1 testPerfMs + updateSessionD session updates2 testPerfMs + updateSessionD session updates1 testPerfMs + updateSessionD session updates2 testPerfMs + assertNoErrors session + where + updates1 = foldr (\n ups -> updDepKN n n <> ups) + mempty + [1..testPerfMs] + updates2 = foldr (\n ups -> updDepKN 42 n <> ups) + mempty + [1..testPerfMs] + +test_NoContext_1 :: TestSuiteEnv -> Assertion +test_NoContext_1 env = withAvailableSession env $ \session -> limitPerfTest $ do + updateSessionD session (updateCodeGeneration True) 1 + mapM_ (\k -> updateSessionD session (upd k) 1) [1..testPerfTimes] + assertNoErrors session + where + upd k = updKN k 1 + +test_NoContext_2 :: TestSuiteEnv -> Assertion +test_NoContext_2 env = withAvailableSession env $ \session -> limitPerfTest $ do + updateSessionD session (updateCodeGeneration True) 1 + mapM_ (\k -> updateSessionD session (upd k) 1) [1..testPerfTimes] + assertNoErrors session + where + upd k = updDepKN k 1 + +test_UpdateModule_1 :: TestSuiteEnv -> Assertion +test_UpdateModule_1 env = withAvailableSession env $ \session -> limitPerfTest $ do + updateSessionD session (updateCodeGeneration True) 1 + updateSessionD session updates testPerfMs + mapM_ (\k -> updateSessionD session (upd k) 1) [1..testPerfTimes] + assertNoErrors session + where + updates = foldr (\n ups -> ups <> updKN n n) + mempty + [1..testPerfMs] + + upd k = updKN k (testPerfMs `div` 2) + +test_UpdateModule_2 :: TestSuiteEnv -> Assertion +test_UpdateModule_2 env = withAvailableSession env $ \session -> limitPerfTest $ do + updateSessionD session (updateCodeGeneration True) 1 + updateSessionD session updates testPerfMsFixed + mapM_ (\k -> updateSessionD session (upd k) (1 + testPerfMsFixed `div` 2)) [1..testPerfTimes] + assertNoErrors session + where + updates = foldr (\n ups -> ups <> updDepKN n n) + mempty + [1..testPerfMsFixed] + + testPerfMsFixed = 50 -- dependencies force recompilation: slow + upd k = updDepKN k (testPerfMsFixed `div` 2) + +test_UpdateAndRun_1 :: TestSuiteEnv -> Assertion +test_UpdateAndRun_1 env = withAvailableSession env $ \session -> limitPerfTest $ do + updateSessionD session (updateCodeGeneration True) 1 + updateSessionD session updates testPerfMsFixed + mapM_ (\k -> do + updateSessionD session (upd k) 1 + runActions <- runStmt session mdiv2 "m" + void $ runWaitAll runActions + ) [1..testPerfTimes] + assertNoErrors session + where + updates = foldr (\n ups -> ups <> updKN n n) + mempty + [1..testPerfMsFixed] + + testPerfMsFixed = testPerfMs * 1 `div` 2 -- running has overheads + upd k = updKN k (testPerfMsFixed `div` 2) + mdiv2 = "M" ++ show (testPerfMsFixed `div` 2) + +test_UpdateAndRun_2 :: TestSuiteEnv -> Assertion +test_UpdateAndRun_2 env = withAvailableSession env $ \session -> limitPerfTest $ do + updateSessionD session (updateCodeGeneration True) 1 + updateSessionD session updates testPerfMsFixed + mapM_ (\k -> do + updateSessionD session (upd k) (1 + testPerfMsFixed `div` 2) + runActions <- runStmt session mdiv2 "m" + void $ runWaitAll runActions + ) [1..testPerfTimes] + assertNoErrors session + where + updates = foldr (\n ups -> ups <> updDepKN n n) + mempty + [1..testPerfMsFixed] + + testPerfMsFixed = 40 -- dependencies force recompilation: slow + upd k = updDepKN k (testPerfMsFixed `div` 2) + mdiv2 = "M" ++ show (testPerfMsFixed `div` 2) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +limitPerfTest :: IO () -> IO () +limitPerfTest t = do + mu <- timeout (testPerfLimit * 1000000) t + case mu of + Nothing -> fail "Performance test did not finish within alotted time" + Just () -> return () + +-- TODO: This should use tasty command line arguments instead +testPerfMs :: Int +{-# NOINLINE testPerfMs #-} +testPerfMs = read $ unsafePerformIO $ + System.getEnv "IDE_BACKEND_testPerfMs" + `Ex.catch` (\(_ :: Ex.IOException) -> return "150") + +-- TODO: This should use tasty command line arguments instead +testPerfTimes :: Int +{-# NOINLINE testPerfTimes #-} +testPerfTimes = read $ unsafePerformIO $ + System.getEnv "IDE_BACKEND_testPerfTimes" + `Ex.catch` (\(_ :: Ex.IOException) -> return "150") + +-- TODO: This should use tasty command line arguments instead +testPerfLimit :: Int +{-# NOINLINE testPerfLimit #-} +testPerfLimit = read $ unsafePerformIO $ + System.getEnv "IDE_BACKEND_testPerfLimit" + `Ex.catch` (\(_ :: Ex.IOException) -> return "30") + +updKN :: Int -> Int -> IdeSessionUpdate +updKN k n = + let moduleN = L.fromString $ unlines $ + [ "module M" ++ show n ++ " where" + , "import Control.Concurrent (threadDelay)" + , "m :: IO ()" + , "m = threadDelay " ++ show k + ] + in updateSourceFile ("M" ++ show n ++ ".hs") moduleN + +updDepKN :: Int -> Int -> IdeSessionUpdate +updDepKN k n = + let depN | n <= 1 = ("System.IO", ".hFlush System.IO.stdout") + | otherwise = ("M" ++ show (n - 1), ".m") + moduleN = L.fromString $ unlines $ + [ "module M" ++ show n ++ " where" + , "import Control.Concurrent (threadDelay)" + , "import qualified " ++ fst depN + , "m :: IO ()" + , "m = threadDelay " ++ show k ++ " >> " + ++ fst depN ++ snd depN + ] + in updateSourceFile ("M" ++ show n ++ ".hs") moduleN diff --git a/TestSuite/TestSuite/Tests/SessionRestart.hs b/TestSuite/TestSuite/Tests/SessionRestart.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/SessionRestart.hs @@ -0,0 +1,186 @@ +module TestSuite.Tests.SessionRestart (testGroupSessionRestart) where + +import Control.Concurrent +import Data.Monoid +import System.Exit +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L (unlines) +import qualified Data.Text as T + +import IdeSession +import TestSuite.Assertions +import TestSuite.Session +import TestSuite.State + +testGroupSessionRestart :: TestSuiteEnv -> TestTree +testGroupSessionRestart env = testGroup "Session restart" [ + stdTest env "Well-behaved snippet; after .1 sec" test_WellBehaved + , stdTest env "Blackhole, snippet doesn't swallow exceptions; after .1 sec" test_Blackhole_DontSwallow + , stdTest env "Snippet swallows all exceptions; after .1 sec" test_Swallow + , stdTest env "Black hole, swallow all exceptions; after .1 sec" test_Blackhole_Swallow + , stdTest env "Evil snippet with infinite stack of exception handlers; after .1 sec" test_Evil + , stdTest env "Make sure environment is restored after session restart" test_EnvRestored + ] + +test_WellBehaved :: TestSuiteEnv -> Assertion +test_WellBehaved env = + restartRun env [ "module M where" + , "import Control.Concurrent (threadDelay)" + , "loop :: IO ()" + , "loop = threadDelay 10000 >> loop" + ] (ExitFailure (-9)) -- SIGKILL + +test_Blackhole_DontSwallow :: TestSuiteEnv -> Assertion +test_Blackhole_DontSwallow env = + restartRun env [ "module M where" + , "loop :: IO ()" + , "loop = loop" + ] (ExitFailure (-9)) -- SIGKILL + +test_Swallow :: TestSuiteEnv -> Assertion +test_Swallow env = + restartRun env [ "module M where" + , "" + , "import qualified Control.Exception as Ex" + , "import Control.Concurrent (threadDelay)" + , "" + , "innerLoop :: IO ()" + , "innerLoop = threadDelay 10000 >> innerLoop" + , "" + , "loop :: IO ()" + , "loop = Ex.catch innerLoop $ \\e -> let _ = e :: Ex.SomeException in loop" + ] (ExitFailure (-9)) -- SIGKILL + +test_Blackhole_Swallow :: TestSuiteEnv -> Assertion +test_Blackhole_Swallow env = + restartRun env [ "module M where" + , "" + , "import qualified Control.Exception as Ex" + , "import Control.Concurrent (threadDelay)" + , "" + , "innerLoop :: IO ()" + , "innerLoop = innerLoop" + , "" + , "loop :: IO ()" + , "loop = Ex.catch innerLoop $ \\e -> let _ = e :: Ex.SomeException in loop" + ] (ExitFailure (-9)) -- SIGKILL + +test_Evil :: TestSuiteEnv -> Assertion +test_Evil env = + restartRun env [ "module M where" + , "" + , "import qualified Control.Exception as Ex" + , "" + , "loop :: IO ()" + , "loop = Ex.catch loop $ \\e -> let _ = e :: Ex.SomeException in loop" + ] (ExitFailure (-9)) -- SIGKILL + +test_EnvRestored :: TestSuiteEnv -> Assertion +test_EnvRestored env = withAvailableSession env $ \session -> do + -- Set environment + updateSession session (updateEnv [("Foo", Just "Value1")]) (\_ -> return ()) + + -- Compile and run the code on the first server + updateSessionD session upd 1 + assertNoErrors session + do runActions <- runStmt session "M" "printFoo" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Value1" output + + ifTestingExe env $ do + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "Value1" + outExe + assertEqual "after runExe" ExitSuccess statusExe + + -- Start a new server + serverBefore <- getGhcServer session + restartSession session + + -- Compile the code on the new server + updateSessionD session upd 1 + assertNoErrors session + + -- Make sure the old server exited + exitCodeBefore <- getGhcExitCode serverBefore + assertEqual "exitCodeBefore" (Just (ExitFailure (-9))) exitCodeBefore + + -- Make sure the new server is still alive + serverAfter <- getGhcServer session + exitCodeAfter <- getGhcExitCode serverAfter + assertEqual "exitCodeAfter" Nothing exitCodeAfter + + -- Make sure environment is restored + do runActions <- runStmt session "M" "printFoo" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Value1" output + + ifTestingExe env $ do + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "Value1" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import System.Environment (getEnv)" + , "printFoo :: IO ()" + , "printFoo = getEnv \"Foo\" >>= putStr" + , "main :: IO ()" + , "main = printFoo" + ]) + + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +restartRun :: TestSuiteEnv -> [L.ByteString] -> ExitCode -> Assertion +restartRun env code exitCode = withAvailableSession env $ \session -> do + -- Compile and run the code on the first server + updateSessionD session upd 1 + assertNoErrors session + runActionsBefore <- runStmt session "M" "loop" + + -- Start a new server + threadDelay 100000 + serverBefore <- getGhcServer session + restartSession session + + -- Compile the code on the new server + updateSessionD session upd 1 + assertNoErrors session + + -- Make sure the old server exited + exitCodeBefore <- getGhcExitCode serverBefore + assertEqual "exitCodeBefore" (Just exitCode) exitCodeBefore + + -- Make sure the new server is still alive + serverAfter <- getGhcServer session + exitCodeAfter <- getGhcExitCode serverAfter + assertEqual "exitCodeAfter" Nothing exitCodeAfter + + -- Force cancel the old snippet + forceCancel runActionsBefore + resOrEx <- runWait runActionsBefore + case resOrEx of + Right RunForceCancelled -> return () + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" $ L.unlines code) diff --git a/TestSuite/TestSuite/Tests/SessionState.hs b/TestSuite/TestSuite/Tests/SessionState.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/SessionState.hs @@ -0,0 +1,77 @@ +-- | Maintained state in the sesssion +module TestSuite.Tests.SessionState (testGroupSessionState) where + +import Test.HUnit +import Test.Tasty + +import TestSuite.State +import TestSuite.Assertions +import TestSuite.Session + +testGroupSessionState :: TestSuiteEnv -> TestTree +testGroupSessionState env = testGroup "Session state" [ + stdTest env "Maintain list of compiled modules 1" testListCompiledModules1 + , stdTest env "Maintain list of compiled modules 2" testListCompiledModules2 + , stdTest env "Maintain list of compiled modules 3" testListCompiledModules3 + ] + +testListCompiledModules1 :: TestSuiteEnv -> Assertion +testListCompiledModules1 env = withAvailableSession env $ \session -> do + updateSessionD session (loadModule "XXX.hs" "a = 5") 1 + assertLoadedModules session "XXX" ["XXX"] + updateSessionD session (loadModule "A.hs" "a = 5") 1 + assertLoadedModules session "[m1]" ["A", "XXX"] + updateSessionD session (loadModule "A2.hs" "import A\na2 = A.a") 1 + assertLoadedModules session "[m1, m2]" ["A", "A2", "XXX"] + updateSessionD session (loadModule "A3.hs" "") 1 + assertLoadedModules session "[m1, m2, m3]" ["A", "A2", "A3", "XXX"] + updateSessionD session (loadModule "Wrong.hs" "import A4\na2 = A4.a + 1") 1 + assertLoadedModules session "wrong1" ["A", "A2", "A3", "XXX"] + updateSessionD session (loadModule "Wrong.hs" "import A\na2 = A.a + c") 1 + assertLoadedModules session "wrong2" ["A", "A2", "A3", "XXX"] + updateSessionD session (loadModule "A.hs" "a = c") 1 + -- Module "A" is compiled before "Wrong", fails, so it's invalidated + -- and all modules that depend on it are invalidated. Module "Wrong" + -- is never compiled. + assertLoadedModules session "wrong3" ["A3", "XXX"] + +testListCompiledModules2 :: TestSuiteEnv -> Assertion +testListCompiledModules2 env = withAvailableSession env $ \session -> do + updateSessionD session (loadModule "XXX.hs" "a = 5") 1 + assertLoadedModules session "XXX" ["XXX"] + updateSessionD session (loadModule "A.hs" "a = 5") 1 + assertLoadedModules session "[m1]" ["A", "XXX"] + updateSessionD session (loadModule "A2.hs" "import A\na2 = A.a") 1 + assertLoadedModules session "[m1, m2]" ["A", "A2", "XXX"] + updateSessionD session (loadModule "A3.hs" "") 1 + assertLoadedModules session "[m1, m2, m3]" ["A", "A2", "A3", "XXX"] + updateSessionD session (loadModule "Wrong.hs" "import A4\na2 = A4.a + 1") 1 + assertLoadedModules session "wrong1" ["A", "A2", "A3", "XXX"] + -- This has to be disabled to get the different outcome below: + -- updateSessionD session (loadModule m4 "import A\na2 = A.a + c") 1 + -- assertLoadedModules session "wrong2" [m1, m2, m3, xxx] + -- We get this differemnt outcome both in original 7.4.2 + -- and after the GHC#7231 fix. It's probably caused by target + -- Wrong place before or after target "A" depending on what kind + -- of error Wrong had. This is strange, but not incorrect. + updateSessionD session (loadModule "A.hs" "a = c") 1 + -- Module "Wrong" is compiled first here, fails, so module "A" + -- is never comipiled, so it's not invalidated. + assertLoadedModules session "wrong3" ["A", "A2", "A3", "XXX"] + +testListCompiledModules3 :: TestSuiteEnv -> Assertion +testListCompiledModules3 env = withAvailableSession env $ \session -> do + updateSessionD session (loadModule "A.hs" "a = 5") 1 + assertLoadedModules session "1 [A]" ["A"] + updateSessionD session (loadModule "A.hs" "a = 5 + True") 1 + assertLoadedModules session "1 []" [] + updateSessionD session (loadModule "A.hs" "a = 5") 1 + assertLoadedModules session "2 [A]" ["A"] + updateSessionD session (loadModule "A.hs" "a = 5 + wrong") 1 + assertLoadedModules session "2 []" [] + updateSessionD session (loadModule "A.hs" "a = 5") 1 + assertLoadedModules session "3 [A]" ["A"] + updateSessionD session (loadModule "A.hs" "import WRONG\na = 5") 1 + assertLoadedModules session "3 [A]; wrong imports do not unload old modules" ["A"] + updateSessionD session (loadModule "A.hs" "a = 5 + True") 1 + assertLoadedModules session "3 []" [] diff --git a/TestSuite/TestSuite/Tests/SnippetEnvironment.hs b/TestSuite/TestSuite/Tests/SnippetEnvironment.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/SnippetEnvironment.hs @@ -0,0 +1,387 @@ +-- | Tests for the snippet environment (cwd, available files, env vars, etc.) +module TestSuite.Tests.SnippetEnvironment (testGroupSnippetEnvironment) where + +import Data.Monoid +import System.Exit +import System.FilePath +import System.Process +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.Lazy.Char8 as L (unlines) +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.Text as T + +import IdeSession +import TestSuite.Session +import TestSuite.Assertions +import TestSuite.State + +testGroupSnippetEnvironment :: TestSuiteEnv -> TestTree +testGroupSnippetEnvironment env = testGroup "Snippet environment" $ [ + stdTest env "Set environment variables" test_SetEnvVars + , stdTest env "Test CWD by reading a data file" test_readDataFile + , stdTest env "Test CWD in executable building" test_CwdInExeBuilding + , stdTest env "Set command line arguments" test_SetCmdLineArgs + , stdTest env "Check that command line arguments survive restartSession" test_CmdLineArgsAfterRestart + ] ++ exeTests env [ + stdTest env "Set environment variables in runExe" test_SetEnvVars_runExe + ] + +test_SetEnvVars :: TestSuiteEnv -> Assertion +test_SetEnvVars env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + -- At the start, both Foo and Bar are undefined + do runActions <- runStmt session "M" "printFoo" + (_, result) <- runWaitAll runActions + case result of + RunProgException ex -> assertEqual "" ex "IOException: Foo: getEnv: does not exist (no environment variable)" + _ -> assertFailure $ "Unexpected result " ++ show result + do runActions <- runStmt session "M" "printBar" + (_, result) <- runWaitAll runActions + case result of + RunProgException ex -> assertEqual "" ex "IOException: Bar: getEnv: does not exist (no environment variable)" + _ -> assertFailure $ "Unexpected result " ++ show result + + -- Update Foo, leave Bar undefined + updateSession session (updateEnv [("Foo", Just "Value1")]) (\_ -> return ()) + do runActions <- runStmt session "M" "printFoo" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Value1" output + do runActions <- runStmt session "M" "printBar" + (_, result) <- runWaitAll runActions + assertEqual "" result (RunProgException "IOException: Bar: getEnv: does not exist (no environment variable)") + + -- Update Bar, leave Foo defined + updateSession session (updateEnv [("Foo", Just "Value1"), ("Bar", Just "Value2")]) (\_ -> return ()) + do runActions <- runStmt session "M" "printFoo" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Value1" output + do runActions <- runStmt session "M" "printBar" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Value2" output + + -- Unset Foo, leave Bar defined + updateSession session (updateEnv [("Foo", Nothing), ("Bar", Just "Value2")]) (\_ -> return ()) + do runActions <- runStmt session "M" "printFoo" + (_, result) <- runWaitAll runActions + assertEqual "" result (RunProgException "IOException: Foo: getEnv: does not exist (no environment variable)") + do runActions <- runStmt session "M" "printBar" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Value2" output + + -- Rely on statelessness of updateEnv to reset Bar + updateSession session (updateEnv []) (\_ -> return ()) + do runActions <- runStmt session "M" "printFoo" + (_, result) <- runWaitAll runActions + case result of + RunProgException ex -> assertEqual "" ex "IOException: Foo: getEnv: does not exist (no environment variable)" + _ -> assertFailure $ "Unexpected result " ++ show result + do runActions <- runStmt session "M" "printBar" + (_, result) <- runWaitAll runActions + case result of + RunProgException ex -> assertEqual "" ex "IOException: Bar: getEnv: does not exist (no environment variable)" + _ -> assertFailure $ "Unexpected result " ++ show result + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import System.Environment (getEnv)" + , "printFoo :: IO ()" + , "printFoo = getEnv \"Foo\" >>= putStr" + , "printBar :: IO ()" + , "printBar = getEnv \"Bar\" >>= putStr" + ]) + +test_SetEnvVars_runExe :: TestSuiteEnv -> Assertion +test_SetEnvVars_runExe env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + assertNoErrors session + + -- At the start, both Foo and Bar are undefined + do updateSessionD session (updateArgs ["Foo"]) 1 + runActions <- runExe session "M" + (_, result) <- runWaitAll runActions + assertEqual "" result (ExitFailure 1) + do updateSessionD session (updateArgs ["Bar"]) 1 + runActions <- runExe session "M" + (_, result) <- runWaitAll runActions + assertEqual "" result (ExitFailure 1) + + -- Update Foo, leave Bar undefined + updateSession session (updateEnv [("Foo", Just "Value1")]) (\_ -> return ()) + do updateSessionD session (updateArgs ["Foo"]) 1 + runActions <- runExe session "M" + (output, result) <- runWaitAll runActions + assertEqual "" result ExitSuccess + assertEqual "" "Value1" output + do updateSessionD session (updateArgs ["Bar"]) 1 + runActions <- runExe session "M" + (_, result) <- runWaitAll runActions + assertEqual "" result (ExitFailure 1) + + -- Update Bar, leave Foo defined + updateSession session (updateEnv [("Foo", Just "Value1"), ("Bar", Just "Value2")]) (\_ -> return ()) + do updateSessionD session (updateArgs ["Foo"]) 1 + runActions <- runExe session "M" + (output, result) <- runWaitAll runActions + assertEqual "" result ExitSuccess + assertEqual "" "Value1" output + do updateSessionD session (updateArgs ["Bar"]) 1 + runActions <- runExe session "M" + (output, result) <- runWaitAll runActions + assertEqual "" result ExitSuccess + assertEqual "" "Value2" output + + -- Unset Foo, leave Bar defined + updateSession session (updateEnv [("Foo", Nothing), ("Bar", Just "Value2")]) (\_ -> return ()) + do updateSessionD session (updateArgs ["Foo"]) 1 + runActions <- runExe session "M" + (_, result) <- runWaitAll runActions + assertEqual "" result (ExitFailure 1) + do updateSessionD session (updateArgs ["Bar"]) 1 + runActions <- runExe session "M" + (output, result) <- runWaitAll runActions + assertEqual "" result ExitSuccess + assertEqual "" "Value2" output + + -- Rely on statelessness of updateEnv to reset Bar + updateSession session (updateEnv []) (\_ -> return ()) + do updateSessionD session (updateArgs ["Foo"]) 1 + runActions <- runExe session "M" + (_, result) <- runWaitAll runActions + assertEqual "" result (ExitFailure 1) + do updateSessionD session (updateArgs ["Bar"]) 1 + runActions <- runExe session "M" + (_, result) <- runWaitAll runActions + assertEqual "" result (ExitFailure 1) + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import System.Environment" + , "main :: IO ()" + , "main = do" + , " args <- getArgs" + , " case args of" + , " [\"Foo\"] -> getEnv \"Foo\" >>= putStr" + , " [\"Bar\"] -> getEnv \"Bar\" >>= putStr" + , " _ -> fail \"wrong args\"" + ]) + +test_readDataFile :: TestSuiteEnv -> Assertion +test_readDataFile env = withAvailableSession env $ \session -> do + let update = updateDataFile "datafile.dat" "test data content" + updateSessionD session update 0 + let update2 = loadModule "Main.hs" + "main = readFile \"datafile.dat\" >>= putStrLn" + updateSessionD session update2 1 + assertNoErrors session + let update3 = updateCodeGeneration True + updateSessionD session update3 1 + + do runActions <- runStmt session "Main" "main" + (output, _) <- runWaitAll runActions + assertEqual "compare test data content" "test data content\n" output + + let m = "Main" + ifTestingExe env $ do + let updExe = buildExe [] [(T.pack m, "Main.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "test data content\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + + let update4 = updateDataFile "datafile.dat" "new content" + <> update2 + updateSessionD session update4 1 + + do runActions2 <- runStmt session "Main" "main" + (output2, _) <- runWaitAll runActions2 + assertEqual "compare new content" "new content\n" output2 + + ifTestingExe env $ do + let updExe2 = buildExe [] [(T.pack m, "Main.hs")] + updateSessionD session updExe2 2 + runActionsExe2 <- runExe session m + (outExe2, statusExe2) <- runWaitAll runActionsExe2 + assertEqual "Output from runExe" + "new content\n" + outExe2 + assertEqual "after runExe" ExitSuccess statusExe2 + +test_CwdInExeBuilding :: TestSuiteEnv -> Assertion +test_CwdInExeBuilding env = withAvailableSession env $ \session -> do + let update = updateCodeGeneration True + <> updateDataFile "test.txt" "test data" + let update2 = updateSourceFile "Main.hs" $ L.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module Main where" + , "import Language.Haskell.TH.Syntax" + , "main = putStrLn $(qRunIO (readFile \"test.txt\") >>= lift)" + ] + updateSessionD session (update <> update2) 1 + assertNoErrors session + + output <- do + runActions <- runStmt session "Main" "main" + (output, _) <- runWaitAll runActions + assertEqual "compare test data" "test data\n" output + return output + + let m = "Main" + ifTestingExe env $ do + let upd = buildExe [] [(T.pack m, "Main.hs")] + updateSessionD session upd 2 + distDir <- getDistDir session + out <- readProcess (distDir "build" m m) [] [] + assertEqual "CWD exe output" (L.toString output) out + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + output + outExe + assertEqual "after runExe" ExitSuccess statusExe + +test_SetCmdLineArgs :: TestSuiteEnv -> Assertion +test_SetCmdLineArgs env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + -- Check that default is [] + do runActions <- runStmt session "M" "printArgs" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "[]\n" output + + let m = "M" + ifTestingExe env $ do + let updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "after runExe" ExitSuccess statusExe + assertEqual "Output from runExe" + "[]\n" + outExe + + -- Check that we can set command line arguments + updateSession session (updateArgs ["A", "B", "C"]) (\_ -> return ()) + do runActions <- runStmt session "M" "printArgs" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "[\"A\",\"B\",\"C\"]\n" output + + ifTestingExe env $ do + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "after runExe" ExitSuccess statusExe + assertEqual "Output from runExe" + "[\"A\",\"B\",\"C\"]\n" + outExe + + -- Check that we can change command line arguments + updateSession session (updateArgs ["D", "E"]) (\_ -> return ()) + do runActions <- runStmt session "M" "printArgs" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "[\"D\",\"E\"]\n" output + + ifTestingExe env $ do + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "after runExe" ExitSuccess statusExe + assertEqual "Output from runExe" + "[\"D\",\"E\"]\n" + outExe + + -- Check that we can clear command line arguments + updateSession session (updateArgs []) (\_ -> return ()) + do runActions <- runStmt session "M" "printArgs" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "[]\n" output + + ifTestingExe env $ do + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "after runExe" ExitSuccess statusExe + assertEqual "Output from runExe" + "[]\n" + outExe + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" $ L.unlines + [ "module M where" + , "import System.Environment (getArgs)" + , "printArgs :: IO ()" + , "printArgs = getArgs >>= print" + , "main :: IO ()" + , "main = printArgs" + ]) + +test_CmdLineArgsAfterRestart :: TestSuiteEnv -> Assertion +test_CmdLineArgsAfterRestart env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + -- Sanity check: check before restart session + updateSession session (updateArgs ["A", "B", "C"]) (\_ -> return ()) + do runActions <- runStmt session "M" "printArgs" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "[\"A\",\"B\",\"C\"]\n" output + + let m = "M" + ifTestingExe env $ do + let updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 3 -- TODO: Some modules may be compiled twice (#189) + + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "after runExe" ExitSuccess statusExe + assertEqual "Output from runExe" + "[\"A\",\"B\",\"C\"]\n" + outExe + + -- Restart and update the session + restartSession session + updateSessionD session upd 1 + assertNoErrors session + + -- Check that arguments are still here + do runActions <- runStmt session "M" "printArgs" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "[\"A\",\"B\",\"C\"]\n" output + + ifTestingExe env $ do + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "after runExe" ExitSuccess statusExe + assertEqual "Output from runExe" + "[\"A\",\"B\",\"C\"]\n" + outExe + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" $ L.unlines + [ "module M where" + , "import System.Environment (getArgs)" + , "printArgs :: IO ()" + , "printArgs = getArgs >>= print" + , "main :: IO ()" + , "main = printArgs" + ]) diff --git a/TestSuite/TestSuite/Tests/StdIO.hs b/TestSuite/TestSuite/Tests/StdIO.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/StdIO.hs @@ -0,0 +1,545 @@ +module TestSuite.Tests.StdIO (testGroupStdIO) where + +import Control.Concurrent +import Control.Monad +import Data.Monoid +import System.Exit +import System.Random +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.UTF8 as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.Text as T + +import IdeSession +import TestSuite.Assertions +import TestSuite.Session +import TestSuite.State + +testGroupStdIO :: TestSuiteEnv -> TestTree +testGroupStdIO env = testGroup "Standard I/O" $ [ + stdTest env "Capture stdout (single putStrLn)" test_CaptureStdout_SinglePutStrLn + , stdTest env "Capture stdout (single putStr)" test_CaptureStdout_SinglePutStr + , stdTest env "Capture stdout (single putStr with delay)" test_CaptureStdout_SinglePutStr_Delay + , stdTest env "Capture stdout (multiple putStrLn)" test_CaptureStdout_MultiplePutStrLn + , stdTest env "Capture stdout (mixed putStr and putStrLn)" test_CaptureStdout_Mixed + , stdTest env "Capture stdin (simple echo process)" test_CaptureStdin_SimpleEcho + , stdTest env "Capture stdin (infinite echo process)" test_CaptureStdin_InfiniteEcho + , stdTest env "Capture stderr" test_Stderr + , stdTest env "Merge stdout and stderr" test_Merge + , stdTest env "Interrupt, then capture stdout" test_Interrupt_CaptureStdout + , stdTest env "Snippet closes stdin; next snippet unaffected" test_ClosesStdin + , stdTest env "Snippet closes stdin (interrupted 'interact'); next snippet unaffected" test_ClosesStdin_Interact + , stdTest env "Snippet closes stdout; next snippet unaffected" test_ClosesStdout + , stdTest env "Snippet closes stderr; next snippet unaffected" test_ClosesStderr + , stdTest env "Snippet closes stderr, using timeout buffering" test_ClosesStderr_Timeout + , stdTest env "Make sure encoding is UTF8" test_UTF8 + ] ++ exeTests env [ + stdTest env "Capture stdin (interleave runStmt and runExe)" test_Interleaved + , stdTest env "Merge stdout and stderr (in runExe)" test_Merge_runExe + ] + +test_CaptureStdout_SinglePutStrLn :: TestSuiteEnv -> Assertion +test_CaptureStdout_SinglePutStrLn env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Hello World\n" output + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . unlinesUtf8 $ + [ "module M where" + , "hello :: IO ()" + , "hello = putStrLn \"Hello World\"" + ]) + +test_CaptureStdout_SinglePutStr :: TestSuiteEnv -> Assertion +test_CaptureStdout_SinglePutStr env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Hello World" output + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . unlinesUtf8 $ + [ "module M where" + , "hello :: IO ()" + , "hello = putStr \"Hello World\"" + ]) + +test_CaptureStdout_SinglePutStr_Delay :: TestSuiteEnv -> Assertion +test_CaptureStdout_SinglePutStr_Delay env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "hellohi" output + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . unlinesUtf8 $ + [ "module M where" + , "import Control.Concurrent (threadDelay)" + , "import System.IO" + , "hello :: IO ()" + , "hello = hSetBuffering stdout LineBuffering >> putStr \"hello\" >> threadDelay 1000000 >> putStr \"hi\"" + ]) + +test_CaptureStdout_MultiplePutStrLn :: TestSuiteEnv -> Assertion +test_CaptureStdout_MultiplePutStrLn env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Hello World 1\nHello World 2\nHello World 3\n" output + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . unlinesUtf8 $ + [ "module M where" + , "hello :: IO ()" + , "hello = do putStrLn \"Hello World 1\"" + , " putStrLn \"Hello World 2\"" + , " putStrLn \"Hello World 3\"" + ]) + +test_CaptureStdout_Mixed :: TestSuiteEnv -> Assertion +test_CaptureStdout_Mixed env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Hello World 1\nHello World 2Hello World 3\n" output + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . unlinesUtf8 $ + [ "module M where" + , "hello :: IO ()" + , "hello = do putStrLn \"Hello World 1\"" + , " putStr \"Hello World 2\"" + , " putStrLn \"Hello World 3\"" + ]) + +test_CaptureStdin_SimpleEcho :: TestSuiteEnv -> Assertion +test_CaptureStdin_SimpleEcho env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + do runActions <- runStmt session "M" "echo" + supplyStdin runActions "ECHO!\n" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "ECHO!\n" output + + ifTestingExe env $ do + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + supplyStdin runActionsExe "ECHO!\n" + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "ECHO!\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . unlinesUtf8 $ + [ "module M where" + , "echo :: IO ()" + , "echo = getLine >>= putStrLn" + , "main :: IO ()" + , "main = echo" + ]) + +test_CaptureStdin_InfiniteEcho :: TestSuiteEnv -> Assertion +test_CaptureStdin_InfiniteEcho env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "echo" + + do supplyStdin runActions "ECHO 1!\n" + result <- runWait runActions + assertEqual "" (Left "ECHO 1!\n") result + + do supplyStdin runActions "ECHO 2!\n" + result <- runWait runActions + assertEqual "" (Left "ECHO 2!\n") result + + do interrupt runActions + resOrEx <- runWait runActions + case resOrEx of + Right result -> assertBool "" (isAsyncException result) + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . unlinesUtf8 $ + [ "module M where" + , "import System.IO" + , "import Control.Monad" + , "echo :: IO ()" + , "echo = do hSetBuffering stdout LineBuffering" + , " forever $ getLine >>= putStrLn" + , "main :: IO ()" + , "main = echo" + ]) + +test_Interleaved :: TestSuiteEnv -> Assertion +test_Interleaved env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + + runActions <- runStmt session "M" "echo" + runActionsExe <- runExe session m + + do supplyStdin runActions "ECHO 1!\n" + result <- runWait runActions + assertEqual "" (Left "ECHO 1!\n") result + + do supplyStdin runActionsExe "ECHO 1!\n" + result <- runWait runActionsExe + assertEqual "" (Left "ECHO 1!\n") result + + do supplyStdin runActions "ECHO 2!\n" + result <- runWait runActions + assertEqual "" (Left "ECHO 2!\n") result + + do supplyStdin runActionsExe "ECHO 2!\n" + result <- runWait runActionsExe + assertEqual "" (Left "ECHO 2!\n") result + + do interrupt runActions + resOrEx <- runWait runActions + case resOrEx of + Right result -> assertBool "" (isAsyncException result) + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx + + do supplyStdin runActionsExe "ECHO 3!\n" + result <- runWait runActionsExe + assertEqual "" (Left "ECHO 3!\n") result + + do interrupt runActionsExe + resOrEx <- runWait runActionsExe + case resOrEx of + Right result -> assertEqual "after runExe" (ExitFailure (-2)) result -- SIGINT + _ -> assertFailure $ "Unexpected run result: " ++ show resOrEx + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . unlinesUtf8 $ + [ "module M where" + , "import System.IO" + , "import Control.Monad" + , "echo :: IO ()" + , "echo = do hSetBuffering stdout LineBuffering" + , " forever $ getLine >>= putStrLn" + , "main :: IO ()" + , "main = echo" + ]) + +test_Stderr :: TestSuiteEnv -> Assertion +test_Stderr env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "Hello World\n" output + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . unlinesUtf8 $ + [ "module M where" + , "import System.IO" + , "hello :: IO ()" + , "hello = hPutStrLn stderr \"Hello World\"" + ]) + +test_Merge :: TestSuiteEnv -> Assertion +test_Merge env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "hello" + (output, result) <- runWaitAll runActions + let expectedOutput = L.concat [ + "Hello World 1\n" + , "Hello World 2\n" + , "Hello World 3" + , "Hello World 4" + , "Hello World 5\n" + , "Hello World 6\n" + , "Hello World 7" + , "Hello World 8" + ] + assertEqual "" RunOk result + assertEqual "" expectedOutput output + where + upd = (updateCodeGeneration True) + <> (updateStdoutBufferMode RunNoBuffering) + <> (updateStderrBufferMode RunNoBuffering) + <> (updateSourceFile "M.hs" . unlinesUtf8 $ + [ "module M where" + , "import System.IO" + , "hello :: IO ()" + , "hello = do hPutStrLn stderr \"Hello World 1\"" + , " hPutStrLn stdout \"Hello World 2\"" + , " hPutStr stderr \"Hello World 3\"" + , " hPutStr stdout \"Hello World 4\"" + , " hPutStrLn stderr \"Hello World 5\"" + , " hPutStrLn stdout \"Hello World 6\"" + , " hPutStr stderr \"Hello World 7\"" + , " hPutStr stdout \"Hello World 8\"" + ]) + +test_Merge_runExe :: TestSuiteEnv -> Assertion +test_Merge_runExe env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + let m = "M" + updExe = buildExe [] [(T.pack m, "M.hs")] + updateSessionD session updExe 2 + + runActions <- runExe session "M" + (output, result) <- runWaitAll runActions + let expectedOutput = L.concat [ + "Hello World 1\n" + , "Hello World 2\n" + , "Hello World 3" + , "Hello World 4" + , "Hello World 5\n" + , "Hello World 6\n" + , "Hello World 7" + , "Hello World 8" + ] + assertEqual "" ExitSuccess result + assertEqual "" expectedOutput output + where + -- Note that we have to set buffering here, to match the default + -- buffering for snippets. + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . unlinesUtf8 $ + [ "module M where" + , "import System.IO" + , "main :: IO ()" + , "main = do hSetBuffering stdout NoBuffering" + , " hPutStrLn stderr \"Hello World 1\"" + , " hPutStrLn stdout \"Hello World 2\"" + , " hPutStr stderr \"Hello World 3\"" + , " hPutStr stdout \"Hello World 4\"" + , " hPutStrLn stderr \"Hello World 5\"" + , " hPutStrLn stdout \"Hello World 6\"" + , " hPutStr stderr \"Hello World 7\"" + , " hPutStr stdout \"Hello World 8\"" + ]) + +test_Interrupt_CaptureStdout :: TestSuiteEnv -> Assertion +test_Interrupt_CaptureStdout env = withAvailableSession env $ \session -> do + updateSession session (updateCodeGeneration True) (\_ -> return ()) + let upd1 = updateSourceFile "Main.hs" . unlinesUtf8 $ + [ "import Control.Monad" + , "main = forever $ print 1" + ] + upd2 = updateSourceFile "Main.hs" . unlinesUtf8 $ + [ "main = print 1234" ] + + do updateSessionD session upd1 1 + runActions <- runStmt session "Main" "main" + -- TODO: Not sure why 'interrupt' doesn't work here. + --interrupt runActions + forceCancel runActions + randomRIO (0, 1000000) >>= threadDelay -- Wait between 0 and 1sec + void $ runWaitAll runActions + + ifTestingExe env $ do + let m = "Main" + updExe = buildExe [] [(T.pack m, "Main.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + interrupt runActionsExe + randomRIO (0, 1000000) >>= threadDelay -- Wait between 0 and 1sec + void $ runWaitAll runActionsExe + + do updateSessionD session upd2 1 + runActions <- runStmt session "Main" "main" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "1234\n" output + + ifTestingExe env $ do + let m = "Main" + updExe = buildExe [] [(T.pack m, "Main.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "1234\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + +test_ClosesStdin :: TestSuiteEnv -> Assertion +test_ClosesStdin env = withAvailableSession env $ \session -> do + updateSession session updates2 $ const $ return () + ra2 <- runStmt session "Main" "main" + out2b <- runWait ra2 + assertEqual "" out2b (Right RunOk) + + updateSession session updates3 $ const $ return () + ra3 <- runStmt session "Main" "main" + supplyStdin ra3 "Michael\n" + (output, out3b) <- runWaitAll ra3 + assertEqual "" RunOk out3b + assertEqual "" "Michael\n" output + where + updates2 = mconcat + [ updateCodeGeneration True + , updateSourceFile "Main.hs" "import System.IO\nmain = hClose stdin" + ] + + updates3 = + updateSourceFile "Main.hs" "main = getLine >>= putStrLn" + +test_ClosesStdin_Interact :: TestSuiteEnv -> Assertion +test_ClosesStdin_Interact env = withAvailableSession env $ \session -> do + updateSession session updates2 $ const $ return () + ra2 <- runStmt session "Main" "main" + supplyStdin ra2 "hello\n" + out2a <- runWait ra2 + out2a @?= Left "hello\n" + interrupt ra2 + out2b <- runWait ra2 + case out2b of + Right result -> assertBool "" (isAsyncException result) + _ -> assertFailure $ "Unexpected run result: " ++ show out2b + + updateSession session updates3 $ const $ return () + ra3 <- runStmt session "Main" "main" + out3a <- runWait ra3 + out3a @?= Left "Hi!\n" + supplyStdin ra3 "Michael\n" + out3b <- runWait ra3 + assertEqual "" out3b (Right RunOk) + where + updates2 = mconcat + [ updateCodeGeneration True + , updateSourceFile "Main.hs" "main = getContents >>= putStr" + , updateStdoutBufferMode $ RunLineBuffering Nothing + ] + + updates3 = mconcat + [ updateCodeGeneration True + , updateSourceFile "Main.hs" "main = putStrLn \"Hi!\" >> getLine >> return ()" + , updateStdoutBufferMode $ RunLineBuffering Nothing + ] + +test_ClosesStdout :: TestSuiteEnv -> Assertion +test_ClosesStdout env = withAvailableSession env $ \session -> do + updateSession session updates2 $ const $ return () + ra2 <- runStmt session "Main" "main" + out2b <- runWait ra2 + assertEqual "" out2b (Right RunOk) + + updateSession session updates3 $ const $ return () + ra3 <- runStmt session "Main" "main" + supplyStdin ra3 "Michael\n" + (output, out3b) <- runWaitAll ra3 + assertEqual "" RunOk out3b + assertEqual "" "Michael\n" output + where + updates2 = mconcat + [ updateCodeGeneration True + , updateSourceFile "Main.hs" "import System.IO\nmain = hClose stdout" + ] + + updates3 = + updateSourceFile "Main.hs" "main = getLine >>= putStrLn" + +test_ClosesStderr :: TestSuiteEnv -> Assertion +test_ClosesStderr env = withAvailableSession env $ \session -> do + updateSession session updates2 $ const $ return () + ra2 <- runStmt session "Main" "main" + out2b <- runWait ra2 + assertEqual "" out2b (Right RunOk) + + updateSession session updates3 $ const $ return () + ra3 <- runStmt session "Main" "main" + supplyStdin ra3 "Michael\n" + (output, out3b) <- runWaitAll ra3 + assertEqual "" RunOk out3b + assertEqual "" "Michael\n" output + where + updates2 = mconcat + [ updateCodeGeneration True + , updateSourceFile "Main.hs" "import System.IO\nmain = hClose stderr" + ] + + updates3 = + updateSourceFile "Main.hs" "import System.IO\nmain = getLine >>= hPutStrLn stderr" + +test_ClosesStderr_Timeout :: TestSuiteEnv -> Assertion +test_ClosesStderr_Timeout env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + ra <- runStmt session "Main" "main" + forM_ [1 :: Int .. 3] $ \i -> do + result <- runWait ra + result @?= Left (S.fromString $ show i ++ "\n") + + finalResult <- runWait ra + assertEqual "" finalResult (Right RunOk) + where + upd = mconcat [ + updateCodeGeneration True + , updateStdoutBufferMode $ RunLineBuffering Nothing + , updateStderrBufferMode $ RunBlockBuffering (Just 4096) (Just 250000) + , updateSourceFile "Main.hs" . unlinesUtf8 $ [ + "import Control.Concurrent" + , "import Control.Monad" + , "import System.IO" + , "main :: IO ()" + , "main = do" + , " hClose stderr" + , " forM_ [1 :: Int .. 3] $ \\i -> do" + , " print i" + , " threadDelay 500000" + ] + ] + +test_UTF8 :: TestSuiteEnv -> Assertion +test_UTF8 env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + runActions <- runStmt session "M" "main" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" "你好. 怎么样?\n" (L.toString output) + + {- This is probably not fixable, because the code itself would need + -- to specify IO.utf8, and we don't want to modify it. + let m = "M" + updExe = buildExe [] [(Text.pack m, "M.hs")] + updateSessionD session updExe 2 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "你好\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + -} + where + upd = (updateCodeGeneration True) + <> (updateSourceFile "M.hs" . unlinesUtf8 $ + [ "module M where" + , "main :: IO ()" + , "main = putStrLn \"你好. 怎么样?\"" + ]) + +unlinesUtf8 :: [String] -> L.ByteString +unlinesUtf8 = L.fromString . unlines diff --git a/TestSuite/TestSuite/Tests/TH.hs b/TestSuite/TestSuite/Tests/TH.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/TH.hs @@ -0,0 +1,87 @@ +module TestSuite.Tests.TH (testGroupTH) where + +import Data.Monoid +import Data.Version +import System.Directory +import System.Exit +import System.FilePath +import System.Process +import Test.HUnit +import Test.Tasty +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T + +import IdeSession +import TestSuite.Assertions +import TestSuite.State +import TestSuite.Session + +testGroupTH :: TestSuiteEnv -> TestTree +testGroupTH env = testGroup "TH" $ [ + stdTest env "Code generation on" test_codeGenOn + , stdTest env "Build haddocks from TH" test_TH + , stdTest env "Build .cabal from TH with a wrong libname and don't fail" test_Cabal + ] ++ exeTests env [ + stdTest env "Build executable from TH" test_buildExe + ] + +test_codeGenOn :: TestSuiteEnv -> Assertion +test_codeGenOn env = withAvailableSession' env (withGhcOpts ["-XTemplateHaskell"]) $ \session -> do + withCurrentDirectory "TestSuite/inputs" $ do + (originalUpdate, lm) <- getModulesFrom "TH" + let update = originalUpdate <> updateCodeGeneration True + updateSessionD session update (length lm) + assertNoErrors session + runActions <- runStmt session "TH.TH" "main" + (output, result) <- runWaitAll runActions + assertEqual "" RunOk result + assertEqual "" output "(True,43)\n" + +test_buildExe :: TestSuiteEnv -> Assertion +test_buildExe env = withAvailableSession' env (withGhcOpts ["-XTemplateHaskell"]) $ \session -> do + withCurrentDirectory "TestSuite/inputs" $ do + (originalUpdate, lm) <- getModulesFrom "TH" + let update = originalUpdate <> updateCodeGeneration True + updateSessionD session update (length lm) + assertNoErrors session + let m = "TH.TH" + upd = buildExe ["-rtsopts=all", "-O0"] [(T.pack m, "TH/TH.hs")] + updateSessionD session upd 3 + distDir <- getDistDir session + out <- readProcess (distDir "build" m m) + ["+RTS", "-K4M", "-RTS"] [] + assertEqual "TH.TH exe output" + "(True,43)\n" + out + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "(True,43)\n" + outExe + assertEqual "after runExe" ExitSuccess statusExe + +test_TH :: TestSuiteEnv -> Assertion +test_TH env = withAvailableSession' env (withGhcOpts ["-XTemplateHaskell"]) $ \session -> do + withCurrentDirectory "TestSuite/inputs" $ do + (originalUpdate, lm) <- getModulesFrom "TH" + let update = originalUpdate <> updateCodeGeneration True + updateSessionD session update (length lm) + assertNoErrors session + let upd = buildDoc + updateSessionD session upd 1 + distDir <- getDistDir session + indexExists <- doesFileExist $ distDir "doc/html/main/index.html" + assertBool "TH.TH haddock files" indexExists + hoogleExists <- doesFileExist $ distDir "doc/html/main/main-1.0.txt" + assertBool "TH.TH hoogle files" hoogleExists + +test_Cabal :: TestSuiteEnv -> Assertion +test_Cabal env = withAvailableSession' env (withGhcOpts ["-XTemplateHaskell"]) $ \session -> do + withCurrentDirectory "TestSuite/inputs" $ do + (originalUpdate, lm) <- getModulesFrom "TH" + let update = originalUpdate <> updateCodeGeneration True + updateSessionD session update (length lm) + assertNoErrors session + dotCabalFromName <- getDotCabal session + let dotCabal = dotCabalFromName "--///fo/name" $ Version [-1, -9] [] + assertBool ".cabal not empty" $ not $ L.null dotCabal diff --git a/TestSuite/TestSuite/Tests/TypeInformation.hs b/TestSuite/TestSuite/Tests/TypeInformation.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/TypeInformation.hs @@ -0,0 +1,1669 @@ +module TestSuite.Tests.TypeInformation (testGroupTypeInformation) where + +import Prelude hiding (span, mod) +import Control.Monad +import Data.Monoid +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.ByteString.Lazy.Char8 as L (unlines) + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupTypeInformation :: TestSuiteEnv -> TestTree +testGroupTypeInformation env = testGroup "Type Information" $ [ + stdTest env "Test internal consistency of local id markers" test_Consistency_Local + , stdTest env "Test internal consistency of imported id markers" test_Consistency_Imported + -- TODO: Should these be docTests? + , stdTest env "Subexpression types 1: Simple expressions" test_SubExp_Simple + , stdTest env "Subexpression types 2: TH and QQ" test_SubExp_TH + , stdTest env "Subexpression types 3: Type families (fpco #2609)" test_SubExp_TypeFamilies + , stdTest env "Subexpression types 4: Higher rank types (fpco #2635)" test_SubExp_HigherRank + , stdTest env "Subexpression types 5: Sections of functions with 3 or more args" test_SubExp_Sections + , stdTest env "Use sites 1: Global values" test_UseSites_GlobalValues + , stdTest env "Use sites 2: Types" test_UseSites_Types + , stdTest env "Use sites 3: Local identifiers" test_UseSites_Local + ] ++ docTests env [ + stdTest env "Local identifiers and Prelude" testLocalIdentifiersAndPrelude + , stdTest env "Simple ADTs" testSimpleADTs + , stdTest env "Polymorphism" testPolymorphism + , stdTest env "Multiple modules" testMultipleModules + , withOK env "External packages, type sigs, scoped type vars, kind sigs" testExternalPkgs + , stdTest env "Reusing type variables" testReusingTypeVariables + , stdTest env "Qualified imports" testQualifiedImports + , stdTest env "Imprecise source spans" testImpreciseSourceSpans + , stdTest env "Quasi-quotation (QQ in own package)" testQuasiOwnPackage + , stdTest env "Quasi-quotation (QQ in separate package, check home module info)" testQuasiSeperatePackage + , stdTest env "Template Haskell" testTemplateHaskell + , stdTest env "Take advantage of scope (1)" testScope1 + , stdTest env "Take advantage of scope (2)" testScope2 + , stdTest env "Take advantage of scope (3)" testScope3 + , stdTest env "Take advantage of scope (4)" testScope4 + , stdTest env "Other constructs" testOtherConstructs + , stdTest env "FFI" testFFI + , stdTest env "GADTs" testGADTs + , stdTest env "Other types" testOtherTypes + , stdTest env "Default methods" testDefaultMethods + , stdTest env "Updated session (#142)" testUpdatedSession + , stdTest env "spanInfo vs expTypes (#3043)" testSpanInfoVsExpTypes + , stdTest env "Consistency of IdMap/explicit sharing cache through multiple updates (#88)" test_StateOfCacheThroughoutUpdates + , stdTest env "HsWrapper: WpTyApp" test_HsWrapper_WpTyApp + , stdTest env "HsWrapper: WpTyLam" test_HsWrapper_WpTyLam + , stdTest env "HsWrapper: WpEvApp" test_HsWrapper_WpEvApp + , stdTest env "HsWrapper: WpEvLam" test_HsWrapper_WpEvLam + , stdTest env "HsWrapper: WpCast" test_HsWrapper_WpCast + , stdTest env "HsWrapper: WpFun" test_HsWrapper_WpFun + ] + +test_Consistency_Local :: TestSuiteEnv -> Assertion +test_Consistency_Local env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertOneError session + where + upd = (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import qualified Text.PrettyPrint as Disp" + , "class Text a where" + , " disp :: a -> Disp.Doc" + , "display :: Text a => a -> String" + , "display = Disp.renderStyle style . disp" + , " where style = Disp.Style {}" + ]) + +test_Consistency_Imported :: TestSuiteEnv -> Assertion +test_Consistency_Imported env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + where + upd = (updateSourceFile "M.hs" . L.unlines $ + [ "module M where" + , "import qualified Text.PrettyPrint as Disp" + , "class Text a where" + , " disp :: a -> Disp.Doc" + , "display :: Text a => a -> String" + , "display = Disp.renderStyle astyle . disp" + , " where astyle = Disp.Style {" + , " Disp.mode = Disp.PageMode," + , " Disp.lineLength = 79," + , " Disp.ribbonsPerLine = 1.0" + , " }" + ]) + +testLocalIdentifiersAndPrelude :: TestSuiteEnv -> Assertion +testLocalIdentifiersAndPrelude env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + assertIdInfo session "A" (2,1,2,2) "a" VarName "Int" "main:A" "A.hs@2:1-2:2" "" "binding occurrence" + assertIdInfo session "A" (3,1,3,2) "b" VarName "Int" "main:A" "A.hs@3:1-3:2" "" "binding occurrence" + assertIdInfo session "A" (3,5,3,6) "a" VarName "Int" "main:A" "A.hs@2:1-2:2" "" "defined locally" + assertIdInfo session "A" (3,7,3,8) "+" VarName "Num a => a -> a -> a" "base-4.5.1.0:GHC.Num" "" "base-4.5.1.0:Prelude" "imported from base-4.5.1.0:Prelude at A.hs@1:8-1:9" + assertIdInfo session "A" (4,1,4,2) "c" VarName "Bool" "main:A" "A.hs@4:1-4:2" "" "binding occurrence" + assertIdInfo session "A" (4,5,4,9) "True" DataName "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Bool" "wired in to the compiler" + assertIdInfo session "A" (5,1,5,2) "d" VarName "[a] -> [a]" "main:A" "A.hs@5:1-5:2" "" "binding occurrence" + assertIdInfo' session "A" (5,5,5,12) (5,5,5,12) "reverse" VarName (allVersions "[a] -> [a]") (allVersions "base-4.5.1.0:GHC.List") (allVersions "") (from710 "base-4.5.1.0:Data.List" "base-4.8.0.0:GHC.OldList") (allVersions "imported from base-4.5.1.0:Prelude at A.hs@1:8-1:9") + + {- TODO: reenable + assertEqual "Haddock link for A.b should be correct" + "main/latest/doc/html/A.html#v:b" $ + haddockLink (idMapToMap idMapB Map.! SourceSpan "B.hs" 5 8 5 9) + -} + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "a = (5 :: Int)" + , "b = a + 6" + , "c = True" + , "d = reverse" + ] + +testSimpleADTs :: TestSuiteEnv -> Assertion +testSimpleADTs env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + assertIdInfo' session "A" (2,6,2,7) (2,6,2,7) "T" TcClsName [] (allVersions "main:A") (from78 "A.hs@2:6-2:7" "A.hs@2:1-2:13") (allVersions "") (allVersions "binding occurrence") + assertIdInfo session "A" (2,10,2,13) "MkT" DataName "T" "main:A" "A.hs@2:10-2:13" "" "binding occurrence" + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "data T = MkT" + ] + +testPolymorphism :: TestSuiteEnv -> Assertion +testPolymorphism env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + assertIdInfo' session "A" (2,6,2,12) (2,6,2,12) "TMaybe" TcClsName [] (allVersions "main:A") (from78 "A.hs@2:6-2:12" "A.hs@2:1-2:35") (allVersions "") (allVersions "binding occurrence") + assertIdInfo session "A" (2,13,2,14) "a" TvName "" "main:A" "A.hs@2:13-2:14" "" "binding occurrence" + assertIdInfo session "A" (2,17,2,25) "TNothing" DataName "TMaybe a" "main:A" "A.hs@2:17-2:25" "" "binding occurrence" + assertIdInfo' session "A" (2,28,2,33) (2,28,2,33) "TJust" DataName (allVersions "a -> TMaybe a") (allVersions "main:A") (from78 "A.hs@2:28-2:33" "A.hs@2:28-2:35") (allVersions "") (allVersions "binding occurrence") + assertIdInfo session "A" (2,34,2,35) "a" TvName "" "main:A" "A.hs@2:13-2:14" "" "defined locally" + assertIdInfo session "A" (4,1,4,3) "f1" VarName "t -> t" "main:A" "A.hs@4:1-4:3" "" "binding occurrence" + assertIdInfo session "A" (4,4,4,5) "x" VarName "t" "main:A" "A.hs@4:4-4:5" "" "binding occurrence" + assertIdInfo session "A" (4,8,4,9) "x" VarName "t" "main:A" "A.hs@4:4-4:5" "" "defined locally" + assertIdInfo session "A" (5,1,5,3) "f2" VarName "t -> t" "main:A" "A.hs@5:1-5:3" "" "binding occurrence" + assertIdInfo session "A" (5,7,5,8) "x" VarName "t" "main:A" "A.hs@5:7-5:8" "" "binding occurrence" + assertIdInfo session "A" (5,12,5,13) "x" VarName "t" "main:A" "A.hs@5:7-5:8" "" "defined locally" + assertIdInfo session "A" (7,1,7,3) "g1" VarName "t -> t1 -> t" "main:A" "A.hs@7:1-7:3" "" "binding occurrence" + assertIdInfo session "A" (7,4,7,5) "x" VarName "t" "main:A" "A.hs@7:4-7:5" "" "binding occurrence" + assertIdInfo session "A" (7,6,7,7) "y" VarName "t1" "main:A" "A.hs@7:6-7:7" "" "binding occurrence" + assertIdInfo session "A" (7,10,7,11) "x" VarName "t" "main:A" "A.hs@7:4-7:5" "" "defined locally" + assertIdInfo session "A" (8,1,8,3) "g2" VarName "t -> t1 -> t" "main:A" "A.hs@8:1-8:3" "" "binding occurrence" + assertIdInfo session "A" (8,7,8,8) "x" VarName "t" "main:A" "A.hs@8:7-8:8" "" "binding occurrence" + assertIdInfo session "A" (8,9,8,10) "y" VarName "t1" "main:A" "A.hs@8:9-8:10" "" "binding occurrence" + assertIdInfo session "A" (8,14,8,15) "x" VarName "t" "main:A" "A.hs@8:7-8:8" "" "defined locally" + assertIdInfo session "A" (10,1,10,3) "h1" VarName "Bool" "main:A" "A.hs@10:1-10:3" "" "binding occurrence" + assertIdInfo session "A" (10,6,10,10) "h1go" VarName "t -> t1 -> t" "main:A" "A.hs@12:5-12:9" "" "defined locally" + assertIdInfo session "A" (10,11,10,15) "True" DataName "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Bool" "wired in to the compiler" + assertIdInfo session "A" (10,16,10,21) "False" DataName "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Bool" "wired in to the compiler" + assertIdInfo session "A" (12,5,12,9) "h1go" VarName "t -> t1 -> t" "main:A" "A.hs@12:5-12:9" "" "binding occurrence" + assertIdInfo session "A" (12,10,12,11) "x" VarName "t" "main:A" "A.hs@12:10-12:11" "" "binding occurrence" + assertIdInfo session "A" (12,12,12,13) "y" VarName "t1" "main:A" "A.hs@12:12-12:13" "" "binding occurrence" + assertIdInfo session "A" (12,16,12,17) "x" VarName "t" "main:A" "A.hs@12:10-12:11" "" "defined locally" + assertIdInfo session "A" (14,1,14,3) "h2" VarName "Bool" "main:A" "A.hs@14:1-14:3" "" "binding occurrence" + assertIdInfo session "A" (14,6,14,10) "h2go" VarName "t -> t1 -> t" "main:A" "A.hs@16:5-16:9" "" "defined locally" + assertIdInfo session "A" (14,11,14,15) "True" DataName "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Bool" "wired in to the compiler" + assertIdInfo session "A" (14,16,14,21) "False" (DataName) "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Bool" "wired in to the compiler" + assertIdInfo session "A" (16,5,16,9) "h2go" VarName "t -> t1 -> t" "main:A" "A.hs@16:5-16:9" "" "binding occurrence" + assertIdInfo session "A" (16,13,16,14) "x" VarName "t" "main:A" "A.hs@16:13-16:14" "" "binding occurrence" + assertIdInfo session "A" (16,15,16,16) "y" VarName "t1" "main:A" "A.hs@16:15-16:16" "" "binding occurrence" + assertIdInfo session "A" (16,20,16,21) "x" VarName "t" "main:A" "A.hs@16:13-16:14" "" "defined locally" + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "data TMaybe a = TNothing | TJust a" + , "" + , "f1 x = x" + , "f2 = \\x -> x" + , "" + , "g1 x y = x" + , "g2 = \\x y -> x" + , "" + , "h1 = h1go True False" + , " where" + , " h1go x y = x" + , "" + , "h2 = h2go True False" + , " where" + , " h2go = \\x y -> x" + ] + +testMultipleModules :: TestSuiteEnv -> Assertion +testMultipleModules env = withAvailableSession env $ \session -> do + updateSessionD session upd 2 + assertNoErrors session + assertIdInfo' session "A" (2,6,2,7) (2,6,2,7) "T" TcClsName [] (allVersions "main:A") (from78 "A.hs@2:6-2:7" "A.hs@2:1-2:13") (allVersions "") (allVersions "binding occurrence") + assertIdInfo session "A" (2,10,2,13) "MkT" DataName "T" "main:A" "A.hs@2:10-2:13" "" "binding occurrence" + assertIdInfo session "B" (3,1,3,4) "foo" VarName "T" "main:B" "B.hs@3:1-3:4" "" "binding occurrence" + assertIdInfo session "B" (3,7,3,10) "MkT" DataName "T" "main:A" "A.hs@2:10-2:13" "" "imported from main:A at B.hs@2:1-2:9" + where + upd = (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "data T = MkT" + ]) + -- Make sure that an occurrence of MkT in a second module + -- doesn't cause us to lose type information we learned + -- while processing the first + <> (updateSourceFile "B.hs" . L.unlines $ + [ "module B where" + , "import A" + , "foo = MkT" + ]) + +testExternalPkgs :: TestSuiteEnv -> IO String +testExternalPkgs env = withAvailableSession' env (withGhcOpts opts) $ \session -> do + updateSessionD session upd 2 + assertNoErrors session + assertIdInfo session "A" (3,1,3,2) "e" VarName "Bool" "main:A" "A.hs@3:1-3:2" "" "binding occurrence" + assertIdInfo session "A" (3,5,3,9) "True" DataName "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Bool" "wired in to the compiler" + assertIdInfo session "A" (3,17,3,22) "False" DataName "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Bool" "wired in to the compiler" + assertIdInfo session "A" (4,1,4,2) "f" VarName "a -> a" "main:A" "A.hs@5:1-5:2" "" "defined locally" + assertIdInfo' session "A" (4,6,4,7) (4,6,4,7) "a" TvName [] (allVersions "main:A") (from78 "A.hs@4:6-4:7" "A.hs@4:6-4:12") (allVersions "") (allVersions "defined locally") + assertIdInfo' session "A" (4,11,4,12) (4,11,4,12) "a" TvName [] (allVersions "main:A") (from78 "A.hs@4:6-4:7" "A.hs@4:6-4:12") (allVersions "") (allVersions "defined locally") + assertIdInfo session "A" (5,1,5,2) "f" VarName "a -> a" "main:A" "A.hs@5:1-5:2" "" "binding occurrence" + assertIdInfo session "A" (5,3,5,4) "x" VarName "a" "main:A" "A.hs@5:3-5:4" "" "binding occurrence" + assertIdInfo session "A" (5,7,5,8) "x" VarName "a" "main:A" "A.hs@5:3-5:4" "" "defined locally" + assertIdInfo session "A" (6,1,6,2) "g" VarName "a -> a" "main:A" "A.hs@7:1-7:2" "" "defined locally" + assertIdInfo session "A" (6,13,6,14) "a" TvName "" "main:A" "A.hs@6:13-6:14" "" "binding occurrence" + assertIdInfo session "A" (6,16,6,17) "a" TvName "" "main:A" "A.hs@6:13-6:14" "" "defined locally" + assertIdInfo session "A" (6,21,6,22) "a" TvName "" "main:A" "A.hs@6:13-6:14" "" "defined locally" + assertIdInfo session "A" (7,1,7,2) "g" VarName "a -> a" "main:A" "A.hs@7:1-7:2" "" "binding occurrence" + assertIdInfo session "A" (7,3,7,4) "x" VarName "a" "main:A" "A.hs@7:3-7:4" "" "binding occurrence" + assertIdInfo session "A" (7,7,7,8) "x" VarName "a" "main:A" "A.hs@7:3-7:4" "" "defined locally" + assertIdInfo session "A" (8,1,8,2) "h" VarName "a -> a" "main:A" "A.hs@9:1-9:2" "" "defined locally" + assertIdInfo session "A" (8,13,8,14) "a" TvName "" "main:A" "A.hs@8:13-8:14" "" "binding occurrence" + assertIdInfo session "A" (8,16,8,17) "a" TvName "" "main:A" "A.hs@8:13-8:14" "" "defined locally" + assertIdInfo session "A" (8,21,8,22) "a" TvName "" "main:A" "A.hs@8:13-8:14" "" "defined locally" + assertIdInfo session "A" (9,1,9,2) "h" VarName "a -> a" "main:A" "A.hs@9:1-9:2" "" "binding occurrence" + assertIdInfo session "A" (9,3,9,4) "x" VarName "a" "main:A" "A.hs@9:3-9:4" "" "binding occurrence" + assertIdInfo session "A" (9,7,9,8) "y" VarName "a" "main:A" "A.hs@12:5-12:6" "" "defined locally" + assertIdInfo session "A" (11,5,11,6) "y" VarName "a" "main:A" "A.hs@12:5-12:6" "" "defined locally" + assertIdInfo session "A" (11,5,11,6) "y" VarName "a" "main:A" "A.hs@12:5-12:6" "" "defined locally" + assertIdInfo session "A" (11,10,11,11) "a" TvName "" "main:A" "A.hs@8:13-8:14" "" "defined locally" + assertIdInfo session "A" (11,10,11,11) "a" TvName "" "main:A" "A.hs@8:13-8:14" "" "defined locally" + assertIdInfo session "A" (12,5,12,6) "y" VarName "a" "main:A" "A.hs@12:5-12:6" "" "binding occurrence" + assertIdInfo session "A" (12,9,12,10) "x" VarName "a" "main:A" "A.hs@9:3-9:4" "" "defined locally" + assertIdInfo session "A" (13,1,13,2) "i" VarName "t a -> t a" "main:A" "A.hs@14:1-14:2" "" "defined locally" + + -- Pre 7.10 we don't get accurate location information for type variables (instead, the location of the + -- entire kind signature (t :: * -> *) is reported. This is fixed in 7.10. + case testSuiteEnvGhcVersion env of + GHC_7_4 -> assertIdInfo session "A" (13,13,13,26) "t" TvName "" "main:A" "A.hs@13:13-13:26" "" "binding occurrence" + GHC_7_8 -> assertIdInfo session "A" (13,13,13,26) "t" TvName "" "main:A" "A.hs@13:13-13:26" "" "binding occurrence" + GHC_7_10 -> assertIdInfo session "A" (13,14,13,15) "t" TvName "" "main:A" "A.hs@13:13-13:26" "" "binding occurrence" + + assertIdInfo session "A" (13,27,13,28) "a" TvName "" "main:A" "A.hs@13:27-13:28" "" "binding occurrence" + assertIdInfo session "A" (13,30,13,31) "t" TvName "" "main:A" "A.hs@13:13-13:26" "" "defined locally" + assertIdInfo session "A" (13,32,13,33) "a" TvName "" "main:A" "A.hs@13:27-13:28" "" "defined locally" + assertIdInfo session "A" (13,37,13,38) "t" TvName "" "main:A" "A.hs@13:13-13:26" "" "defined locally" + assertIdInfo session "A" (13,39,13,40) "a" TvName "" "main:A" "A.hs@13:27-13:28" "" "defined locally" + assertIdInfo session "A" (14,1,14,2) "i" VarName "t a -> t a" "main:A" "A.hs@14:1-14:2" "" "binding occurrence" + assertIdInfo session "A" (14,3,14,4) "x" VarName "t a" "main:A" "A.hs@14:3-14:4" "" "binding occurrence" + assertIdInfo session "A" (14,7,14,8) "x" VarName "t a" "main:A" "A.hs@14:3-14:4" "" "defined locally" + fixme session "#254" $ assertIdInfo session "A" (3,10,3,16) "pseq" VarName "a -> b -> b" "parallel-3.2.0.3:Control.Parallel" "" "parallel-3.2.0.3:Control.Parallel" "imported from parallel-3.2.0.3:Control.Parallel at A.hs@2:1-2:24" + where + opts = [ "-XScopedTypeVariables" + , "-XKindSignatures" + ] + + upd = updateSourceFile "A.hs" . L.unlines $ + [ {- 1 -} "module A where" + + , {- 2 -} "import Control.Parallel" + + , {- 3 -} "e = True `pseq` False" + + , {- 4 -} "f :: a -> a" + , {- 5 -} "f x = x" + + , {- 6 -} "g :: forall a. a -> a" + , {- 7 -} "g x = x" + + , {- 8 -} "h :: forall a. a -> a" + , {- 9 -} "h x = y" + , {- 10 -} " where" + , {- 11 -} " y :: a" + , {- 12 -} " y = x" + + -- 1 2 3 + -- 123456789012345678901234567890123456789 + , {- 13 -} "i :: forall (t :: * -> *) a. t a -> t a" + , {- 14 -} "i x = x" + ] + +testReusingTypeVariables :: TestSuiteEnv -> Assertion +testReusingTypeVariables env = withAvailableSession' env (withGhcOpts ["-XScopedTypeVariables"]) $ \session -> do + updateSessionD session upd 2 + assertNoErrors session + assertIdInfo session "A" (2,1,2,3) "f1" VarName "(t, t1) -> t" "main:A" "A.hs@2:1-2:3" "" "binding occurrence" + assertIdInfo session "A" (2,5,2,6) "x" VarName "t" "main:A" "A.hs@2:5-2:6" "" "binding occurrence" + assertIdInfo session "A" (2,8,2,9) "y" VarName "t1" "main:A" "A.hs@2:8-2:9" "" "binding occurrence" + assertIdInfo session "A" (2,13,2,14) "x" VarName "t" "main:A" "A.hs@2:5-2:6" "" "defined locally" + assertIdInfo session "A" (3,1,3,3) "f2" VarName "(t, t1) -> t" "main:A" "A.hs@3:1-3:3" "" "binding occurrence" + assertIdInfo session "A" (3,5,3,6) "x" VarName "t" "main:A" "A.hs@3:5-3:6" "" "binding occurrence" + assertIdInfo session "A" (3,8,3,9) "y" VarName "t1" "main:A" "A.hs@3:8-3:9" "" "binding occurrence" + assertIdInfo session "A" (3,13,3,14) "x" VarName "t" "main:A" "A.hs@3:5-3:6" "" "defined locally" + assertIdInfo session "A" (4,1,4,3) "f3" VarName "(t, t1) -> t" "main:A" "A.hs@4:1-4:3" "" "binding occurrence" + assertIdInfo session "A" (4,5,4,6) "x" VarName "t" "main:A" "A.hs@4:5-4:6" "" "binding occurrence" + assertIdInfo session "A" (4,8,4,9) "y" VarName "t1" "main:A" "A.hs@4:8-4:9" "" "binding occurrence" + assertIdInfo session "A" (4,13,4,15) "f4" VarName "(t2, t3) -> t2" "main:A" "A.hs@6:5-6:7" "" "defined locally" + assertIdInfo session "A" (4,17,4,18) "x" VarName "t" "main:A" "A.hs@4:5-4:6" "" "defined locally" + assertIdInfo session "A" (4,20,4,21) "y" VarName "t1" "main:A" "A.hs@4:8-4:9" "" "defined locally" + assertIdInfo session "A" (6,5,6,7) "f4" VarName "(t2, t3) -> t2" "main:A" "A.hs@6:5-6:7" "" "binding occurrence" + assertIdInfo session "A" (6,9,6,10) "x" VarName "t2" "main:A" "A.hs@6:9-6:10" "" "binding occurrence" + assertIdInfo session "A" (6,12,6,13) "y" VarName "t3" "main:A" "A.hs@6:12-6:13" "" "binding occurrence" + assertIdInfo session "A" (6,17,6,18) "x" VarName "t2" "main:A" "A.hs@6:9-6:10" "" "defined locally" + assertIdInfo session "A" (7,1,7,3) "f5" VarName "(t, t1) -> t" "main:A" "A.hs@8:1-8:3" "" "defined locally" + assertIdInfo session "A" (7,14,7,15) "t" TvName "" "main:A" "A.hs@7:14-7:15" "" "binding occurrence" + assertIdInfo session "A" (7,16,7,18) "t1" TvName "" "main:A" "A.hs@7:16-7:18" "" "binding occurrence" + assertIdInfo session "A" (7,21,7,22) "t" TvName "" "main:A" "A.hs@7:14-7:15" "" "defined locally" + assertIdInfo session "A" (7,24,7,26) "t1" TvName "" "main:A" "A.hs@7:16-7:18" "" "defined locally" + assertIdInfo session "A" (7,31,7,32) "t" TvName "" "main:A" "A.hs@7:14-7:15" "" "defined locally" + assertIdInfo session "A" (8,1,8,3) "f5" VarName "(t, t1) -> t" "main:A" "A.hs@8:1-8:3" "" "binding occurrence" + assertIdInfo session "A" (8,5,8,6) "x" VarName "t" "main:A" "A.hs@8:5-8:6" "" "binding occurrence" + assertIdInfo session "A" (8,8,8,9) "y" VarName "t1" "main:A" "A.hs@8:8-8:9" "" "binding occurrence" + assertIdInfo session "A" (8,13,8,15) "f6" VarName "(t, t2) -> t" "main:A" "A.hs@11:5-11:7" "" "defined locally" + assertIdInfo session "A" (8,17,8,18) "x" VarName "t" "main:A" "A.hs@8:5-8:6" "" "defined locally" + assertIdInfo session "A" (8,20,8,21) "y" VarName "t1" "main:A" "A.hs@8:8-8:9" "" "defined locally" + assertIdInfo session "A" (10,5,10,7) "f6" VarName "(t, t2) -> t" "main:A" "A.hs@11:5-11:7" "" "defined locally" + assertIdInfo session "A" (10,5,10,7) "f6" VarName "(t, t2) -> t" "main:A" "A.hs@11:5-11:7" "" "defined locally" + assertIdInfo session "A" (10,18,10,20) "t2" TvName "" "main:A" "A.hs@10:18-10:20" "" "binding occurrence" + assertIdInfo session "A" (10,18,10,20) "t2" TvName "" "main:A" "A.hs@10:18-10:20" "" "binding occurrence" + assertIdInfo session "A" (10,23,10,24) "t" TvName "" "main:A" "A.hs@7:14-7:15" "" "defined locally" + assertIdInfo session "A" (10,23,10,24) "t" TvName "" "main:A" "A.hs@7:14-7:15" "" "defined locally" + assertIdInfo session "A" (10,26,10,28) "t2" TvName "" "main:A" "A.hs@10:18-10:20" "" "defined locally" + assertIdInfo session "A" (10,26,10,28) "t2" TvName "" "main:A" "A.hs@10:18-10:20" "" "defined locally" + assertIdInfo session "A" (10,33,10,34) "t" TvName "" "main:A" "A.hs@7:14-7:15" "" "defined locally" + assertIdInfo session "A" (10,33,10,34) "t" TvName "" "main:A" "A.hs@7:14-7:15" "" "defined locally" + assertIdInfo session "A" (11,5,11,7) "f6" VarName "(t, t2) -> t" "main:A" "A.hs@11:5-11:7" "" "binding occurrence" + assertIdInfo session "A" (11,9,11,10) "x" VarName "t" "main:A" "A.hs@11:9-11:10" "" "binding occurrence" + assertIdInfo session "A" (11,12,11,13) "y" VarName "t2" "main:A" "A.hs@11:12-11:13" "" "binding occurrence" + assertIdInfo session "A" (11,17,11,18) "x" VarName "t" "main:A" "A.hs@11:9-11:10" "" "defined locally" + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + + , "f1 (x, y) = x" + , "f2 (x, y) = x" + + , "f3 (x, y) = f4 (x, y)" + , " where" + , " f4 (x, y) = x" + + , "f5 :: forall t t1. (t, t1) -> t" + , "f5 (x, y) = f6 (x, y)" + , " where" + , " f6 :: forall t2. (t, t2) -> t" + , " f6 (x, y) = x" + ] + +testQualifiedImports :: TestSuiteEnv -> Assertion +testQualifiedImports env = withAvailableSession env $ \session -> do + updateSessionD session upd 2 + assertNoErrors session + assertIdInfo session "A" (5,1,5,4) "foo" VarName "(Maybe a -> a, Int -> [a1] -> [a1], (b -> b -> c) -> (a2 -> b) -> a2 -> a2 -> c)" "main:A" "A.hs@5:1-5:4" "" "binding occurrence" + assertIdInfo session "A" (5,8,5,16) "fromJust" VarName "Maybe a2 -> a2" "base-4.5.1.0:Data.Maybe" "" "base-4.5.1.0:Data.Maybe" "imported from base-4.5.1.0:Data.Maybe at A.hs@2:1-2:18" + assertIdInfo' session "A" (5,18,5,32) (5,18,5,32) "take" VarName (allVersions "Int -> [a] -> [a]") (allVersions "base-4.5.1.0:GHC.List") (allVersions "") (from710 "base-4.5.1.0:Data.List" "base-4.8.0.0:GHC.OldList") (allVersions "imported from base-4.5.1.0:Data.List as 'Data.List.' at A.hs@3:1-3:27") + assertIdInfo session "A" (5,34,5,38) "on" VarName "(b1 -> b1 -> c1) -> (a2 -> b1) -> a2 -> a2 -> c1" "base-4.5.1.0:Data.Function" "" "base-4.5.1.0:Data.Function" "imported from base-4.5.1.0:Data.Function as 'F.' at A.hs@4:1-4:36" + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "import Data.Maybe" + , "import qualified Data.List" + , "import qualified Data.Function as F" + , "foo = (fromJust, Data.List.take, F.on)" + ] + +testImpreciseSourceSpans :: TestSuiteEnv -> Assertion +testImpreciseSourceSpans env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + let checkPrint span = assertIdInfo' session "A" span (2, 8, 2, 13) "print" VarName (allVersions "Show a => a -> IO ()") (allVersions "base-4.5.1.0:System.IO") (allVersions "") (allVersions "base-4.5.1.0:System.IO") (allVersions "imported from base-4.5.1.0:Prelude at A.hs@1:8-1:9") + + checkPrint (2,8,2,13) + checkPrint (2,8,2,8) + checkPrint (2,8,2,9) + checkPrint (2,9,2,9) + checkPrint (2,9,2,10) + checkPrint (2,9,2,13) + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "main = print True" + ] + +testQuasiOwnPackage :: TestSuiteEnv -> Assertion +testQuasiOwnPackage env = withAvailableSession env $ \session -> do + updateSessionD session upd 2 + assertNoErrors session + {- + let span l c = SourceSpan { spanFilePath = "B.hs" + , spanFromLine = l + , spanFromColumn = c + , spanToLine = l + , spanToColumn = c + } + print (idInfo (Text.pack "B") (span 4 11)) + print (idInfo (Text.pack "B") (span 5 11)) + print (idInfo (Text.pack "B") (span 6 11)) + print (idInfo (Text.pack "B") (span 7 11)) + -} + assertIdInfo session "B" (4,7,4,14) "qq" VarName "QuasiQuoter" "main:A" "A.hs@4:1-4:3" "" "imported from main:A at B.hs@3:1-3:9" + assertIdInfo session "B" (5,7,5,14) "qq" VarName "QuasiQuoter" "main:A" "A.hs@4:1-4:3" "" "imported from main:A at B.hs@3:1-3:9" + assertIdInfo session "B" (6,7,6,14) "qq" VarName "QuasiQuoter" "main:A" "A.hs@4:1-4:3" "" "imported from main:A at B.hs@3:1-3:9" + assertIdInfo session "B" (7,7,7,14) "qq" VarName "QuasiQuoter" "main:A" "A.hs@4:1-4:3" "" "imported from main:A at B.hs@3:1-3:9" + where + upd = updateCodeGeneration True + <> (updateSourceFile "A.hs" . L.unlines $ + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A where" + , "import Language.Haskell.TH.Quote" + , "qq = QuasiQuoter {" + , " quoteExp = \\str -> case str of" + , " \"a\" -> [| True |]" + , " \"b\" -> [| id True |]" + , " \"c\" -> [| True || False |]" + , " \"d\" -> [| False |]" + , " , quotePat = undefined" + , " , quoteType = undefined" + , " , quoteDec = undefined" + , " }" + ]) + <> (updateSourceFile "B.hs" . L.unlines $ + [ "{-# LANGUAGE QuasiQuotes #-}" + , "module B where" + , "import A" + -- 1234567890123 + , "ex1 = [qq|a|]" + , "ex2 = [qq|b|]" + , "ex3 = [qq|c|]" + , "ex4 = [qq|d|]" + ]) + +testQuasiSeperatePackage :: TestSuiteEnv -> Assertion +testQuasiSeperatePackage env = withAvailableSession env $ \session -> do + updateSessionD session upd 2 + + errs <- getSourceErrors session + case errs of + [] -> do + -- TODO: why don't we get type information here? + assertIdInfo session "Main" (6,19,8,3) "parseRoutes" VarName "" "yesod-routes-1.2.0.1:Yesod.Routes.Parse" "" "yesod-core-1.2.2:Yesod.Core.Dispatch" "imported from yesod-1.2.1:Yesod at Main.hs@3:1-3:13" + assertIdInfo session "Main" (9,26,11,5) "whamlet" VarName "" "yesod-core-1.2.2:Yesod.Core.Widget" "" "yesod-core-1.2.2:Yesod.Core.Widget" "imported from yesod-1.2.1:Yesod at Main.hs@3:1-3:13" + _ -> + skipTest "Probably yesod package not installed" + where + upd = updateCodeGeneration True + <> (updateSourceFile "Main.hs" . L.unlines $ + [ "{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses," + , " TemplateHaskell, OverloadedStrings #-}" + , "import Yesod" + + , "data Piggies = Piggies" + + , "instance Yesod Piggies" + + , "mkYesod \"Piggies\" [parseRoutes|" + , " / HomeR GET" + , "|]" + + , "getHomeR = defaultLayout [whamlet|" + , " Welcome to the Pigsty!" + , " |]" + + , "main = warpEnv Piggies" + ]) + +testTemplateHaskell :: TestSuiteEnv -> Assertion +testTemplateHaskell env = withAvailableSession env $ \session -> do + updateSessionD session upd 2 + assertNoErrors session + assertIdInfo session "A" (4,1,4,4) "ex1" VarName "Q Exp" "main:A" "A.hs@5:1-5:4" "" "defined locally" + assertIdInfo session "A" (4,8,4,9) "Q" TcClsName "" "template-haskell-2.7.0.0:Language.Haskell.TH.Syntax" "" "template-haskell-2.7.0.0:Language.Haskell.TH.Syntax" "imported from template-haskell-2.7.0.0:Language.Haskell.TH at A.hs@3:1-3:27" + assertIdInfo session "A" (4,10,4,13) "Exp" TcClsName "" "template-haskell-2.7.0.0:Language.Haskell.TH.Syntax" "" "template-haskell-2.7.0.0:Language.Haskell.TH.Syntax" "imported from template-haskell-2.7.0.0:Language.Haskell.TH at A.hs@3:1-3:27" + assertIdInfo session "A" (5,1,5,4) "ex1" VarName "Q Exp" "main:A" "A.hs@5:1-5:4" "" "binding occurrence" + assertIdInfo session "A" (5,11,5,12) "x" VarName "" "main:A" "A.hs@5:11-5:12" "" "binding occurrence" + assertIdInfo session "A" (5,16,5,17) "x" VarName "" "main:A" "A.hs@5:11-5:12" "" "defined locally" + assertIdInfo session "A" (6,1,6,4) "ex2" VarName "Q Type" "main:A" "A.hs@7:1-7:4" "" "defined locally" + assertIdInfo session "A" (6,8,6,9) "Q" TcClsName "" "template-haskell-2.7.0.0:Language.Haskell.TH.Syntax" "" "template-haskell-2.7.0.0:Language.Haskell.TH.Syntax" "imported from template-haskell-2.7.0.0:Language.Haskell.TH at A.hs@3:1-3:27" + assertIdInfo session "A" (6,10,6,14) "Type" TcClsName "" "template-haskell-2.7.0.0:Language.Haskell.TH.Syntax" "" "template-haskell-2.7.0.0:Language.Haskell.TH.Syntax" "imported from template-haskell-2.7.0.0:Language.Haskell.TH at A.hs@3:1-3:27" + assertIdInfo session "A" (7,1,7,4) "ex2" VarName "Q Type" "main:A" "A.hs@7:1-7:4" "" "binding occurrence" + assertIdInfo session "A" (7,11,7,17) "String" TcClsName "" "base-4.5.1.0:GHC.Base" "" "base-4.5.1.0:Data.String" "imported from base-4.5.1.0:Prelude at A.hs@2:8-2:9" + assertIdInfo session "A" (7,21,7,27) "String" TcClsName "" "base-4.5.1.0:GHC.Base" "" "base-4.5.1.0:Data.String" "imported from base-4.5.1.0:Prelude at A.hs@2:8-2:9" + assertIdInfo session "B" (4,1,4,4) "ex5" VarName "String -> String" "main:B" "B.hs@5:1-5:4" "" "defined locally" + assertIdInfo session "B" (4,8,4,12) "ex2" VarName "Q Type" "main:A" "A.hs@7:1-7:4" "" "imported from main:A at B.hs@3:1-3:9" + assertIdInfo session "B" (5,1,5,4) "ex5" VarName "String -> String" "main:B" "B.hs@5:1-5:4" "" "binding occurrence" + assertIdInfo session "B" (5,7,5,11) "ex1" VarName "Q Exp" "main:A" "A.hs@5:1-5:4" "" "imported from main:A at B.hs@3:1-3:9" + + assertIdInfo session "B" (6,21,6,24) "ex2" VarName "Q Type" "main:A" "A.hs@7:1-7:4" "" "imported from main:A at B.hs@3:1-3:9" + assertIdInfo session "B" (7,9,7,12) "ex1" VarName "Q Exp" "main:A" "A.hs@5:1-5:4" "" "imported from main:A at B.hs@3:1-3:9" + assertIdInfo session "B" (8,1,8,5) "ex3" VarName "Q [Dec]" "main:A" "A.hs@9:1-9:4" "" "imported from main:A at B.hs@3:1-3:9" + where + upd = updateCodeGeneration True + <> (updateSourceFile "A.hs" . L.unlines $ + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A where" + , "import Language.Haskell.TH" + , "ex1 :: Q Exp" + , "ex1 = [| \\x -> x |]" + , "ex2 :: Q Type" + , "ex2 = [t| String -> String |]" + , "ex3 :: Q [Dec]" + , "ex3 = [d| foo x = x |]" + ]) + <> (updateSourceFile "B.hs" . L.unlines $ + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module B where" + , "import A" + -- Types and expressions + , "ex5 :: $ex2" + , "ex5 = $ex1" + -- Just to test slightly larger expressions + , "ex6 :: $(return =<< ex2)" + , "ex6 = $(ex1 >>= return)" + -- Declarations + , "$ex3" + ]) + +testScope1 :: TestSuiteEnv -> Assertion +testScope1 env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + assertIdInfo session "A" (2,8,2,13) "print" VarName "Show a => a -> IO ()" "base-4.5.1.0:System.IO" "" "base-4.5.1.0:System.IO" "imported from base-4.5.1.0:Prelude at A.hs@1:8-1:9" + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "main = print True" + ] + +testScope2 :: TestSuiteEnv -> Assertion +testScope2 env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + assertIdInfo session "A" (3,7,3,13) "append" VarName "Data.ByteString.Internal.ByteString -> Data.ByteString.Internal.ByteString -> Data.ByteString.Internal.ByteString" "bytestring-0.9.2.1:Data.ByteString" "" "bytestring-0.9.2.1:Data.ByteString" "imported from bytestring-0.9.2.1:Data.ByteString at A.hs@2:25-2:31" + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "import Data.ByteString (append)" + , "foo = append" + ] + +testScope3 :: TestSuiteEnv -> Assertion +testScope3 env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + assertIdInfo session "A" (3,7,3,13) "append" VarName "ByteString -> ByteString -> ByteString" "bytestring-0.9.2.1:Data.ByteString" "" "bytestring-0.9.2.1:Data.ByteString" "imported from bytestring-0.9.2.1:Data.ByteString at A.hs@2:1-2:23" + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "import Data.ByteString" + , "foo = append" + ] + +testScope4 :: TestSuiteEnv -> Assertion +testScope4 env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + assertIdInfo session "A" (4,7,4,13) "append" VarName "BS.ByteString -> BS.ByteString -> BS.ByteString" "bytestring-0.9.2.1:Data.ByteString" "" "bytestring-0.9.2.1:Data.ByteString" "imported from bytestring-0.9.2.1:Data.ByteString as 'BS.' at A.hs@3:1-3:39" + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "import Data.ByteString (append)" + , "import qualified Data.ByteString as BS" + , "foo = append" + ] + +testOtherConstructs :: TestSuiteEnv -> Assertion +testOtherConstructs env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + assertIdInfo session "A" (4,10,4,12) "Eq" TcClsName "" "ghc-prim-0.2.0.0:GHC.Classes" "" "base-4.5.1.0:Data.Eq" "imported from base-4.5.1.0:Prelude at A.hs@2:8-2:9" + assertIdInfo' session "A" (5,18,5,23) (5,18,5,23) "const" VarName (allVersions "a -> b -> a") (allVersions "base-4.5.1.0:GHC.Base") (allVersions "") (from710 "base-4.5.1.0:Prelude" "base-4.8.0.0:Data.Function") (allVersions "imported from base-4.5.1.0:Prelude at A.hs@2:8-2:9") + assertIdInfo session "A" (6,19,6,23) "Show" TcClsName "" "base-4.5.1.0:GHC.Show" "" "base-4.5.1.0:Text.Show" "imported from base-4.5.1.0:Prelude at A.hs@2:8-2:9" + assertIdInfo' session "A" (6,24,6,27) (6,24,6,27) "MkT" TcClsName [] (allVersions "main:A") (from78 "A.hs@3:6-3:9" "A.hs@3:1-3:15") (allVersions "") (allVersions "defined locally") + assertIdInfo session "A" (8,10,8,13) "+++" VarName "[a] -> [a] -> [a]" "main:A" "A.hs@7:1-7:6" "" "defined locally" + assertIdInfo session "A" (9,10,9,13) "Int" TcClsName "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Int" "wired in to the compiler" + assertIdInfo session "A" (17,13,17,14) "x" VarName "Int" "main:A" "A.hs@17:3-17:4" "" "defined locally" + assertIdInfo session "A" (17,21,17,22) "x" VarName "Int" "main:A" "A.hs@17:3-17:4" "" "defined locally" + assertIdInfo session "A" (17,24,17,25) "y" VarName "Int" "main:A" "A.hs@17:5-17:6" "" "defined locally" + assertIdInfo session "A" (17,31,17,32) "x" VarName "Int" "main:A" "A.hs@17:3-17:4" "" "defined locally" + assertIdInfo session "A" (17,36,17,37) "z" VarName "Int" "main:A" "A.hs@17:7-17:8" "" "defined locally" + assertIdInfo session "A" (17,41,17,42) "x" VarName "Int" "main:A" "A.hs@17:3-17:4" "" "defined locally" + assertIdInfo session "A" (17,44,17,45) "y" VarName "Int" "main:A" "A.hs@17:5-17:6" "" "defined locally" + assertIdInfo session "A" (17,49,17,50) "z" VarName "Int" "main:A" "A.hs@17:7-17:8" "" "defined locally" + assertIdInfo session "A" (18,19,18,21) "xs" VarName "[Int]" "main:A" "A.hs@18:19-18:21" "" "binding occurrence" + assertIdInfo' session "A" (18,25,18,29) (18,25,18,29) "Just" DataName [] (from710 "base-4.5.1.0:Data.Maybe" "base-4.8.0.0:GHC.Base") (allVersions "") (allVersions "base-4.5.1.0:Data.Maybe") (allVersions "imported from base-4.5.1.0:Prelude at A.hs@2:8-2:9") + assertIdInfo session "A" (18,35,18,37) "xs" VarName "[Int]" "main:A" "A.hs@18:19-18:21" "" "defined locally" + where + langPragma = case testSuiteEnvGhcVersion env of + GHC_7_4 -> "{-# LANGUAGE StandaloneDeriving, DoRec #-}" + GHC_7_8 -> "{-# LANGUAGE StandaloneDeriving, RecursiveDo #-}" + GHC_7_10 -> "{-# LANGUAGE StandaloneDeriving, RecursiveDo #-}" + + upd = updateSourceFile "A.hs" . L.unlines $ + [ {- 1 -} langPragma + , {- 2 -} "module A where" + + , {- 3 -} "data MkT = MkT" + + , {- 4 -} "instance Eq MkT where" + , {- 5 -} " (==) = const $ const True" + + , {- 6 -} "deriving instance Show MkT" + + , {- 7 -} "(+++) = (++)" + , {- 8 -} "infixr 5 +++" + + , {- 9 -} "default (Int)" + + , {- 10 -} "{-# DEPRECATED f \"This is completely obsolete\" #-}" + , {- 11 -} "f :: Int" + , {- 12 -} "f = 1" + + , {- 13 -} "{-# WARNING g \"You really shouldn't be using g!\" #-}" + , {- 14 -} "g :: Int" + , {- 15 -} "g = 2" + + , {- 16 -} "h :: Int -> Int -> Int -> ([Int], [Int], [Int], [Int])" + , {- 17 -} "h x y z = ([x ..], [x, y..], [x .. z], [x, y .. z])" + + , {- 18 -} "justOnes = do rec xs <- Just (1 : xs)" + , {- 19 -} " return (map negate xs)" + ] + +testFFI :: TestSuiteEnv -> Assertion +testFFI env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + assertIdInfo' session "A" (5,28,5,33) (5,28,5,33) "c_sin" VarName (allVersions "CDouble -> CDouble") (allVersions "main:A") (from78 "A.hs@5:28-5:33" "A.hs@5:1-5:55") (allVersions "") (allVersions "binding occurrence") + assertIdInfo session "A" (5,37,5,44) "CDouble" TcClsName "" "base-4.5.1.0:Foreign.C.Types" "" "base-4.5.1.0:Foreign.C.Types" "imported from base-4.5.1.0:Foreign.C at A.hs@4:1-4:17" + assertIdInfo session "A" (10,22,10,29) "andBack" VarName "CDouble -> CDouble" "main:A" "A.hs@9:1-9:8" "" "defined locally" + assertIdInfo session "A" (10,33,10,40) "CDouble" TcClsName "" "base-4.5.1.0:Foreign.C.Types" "" "base-4.5.1.0:Foreign.C.Types" "imported from base-4.5.1.0:Foreign.C at A.hs@4:1-4:17" + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "{-# LANGUAGE ForeignFunctionInterface #-}" + , "module A where" + + , "import Prelude hiding (sin)" + , "import Foreign.C" + + , "foreign import ccall \"sin\" c_sin :: CDouble -> CDouble" + + , "sin :: Double -> Double" + , "sin d = realToFrac (c_sin (realToFrac d))" + + , "andBack :: CDouble -> CDouble" + , "andBack = realToFrac . sin . realToFrac" + + , "foreign export ccall andBack :: CDouble -> CDouble" + ] + +testGADTs :: TestSuiteEnv -> Assertion +testGADTs env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + -- TODO: These types should not contain explicit coercions (#68) + assertIdInfo' session "A" (4,3,4,6) (4,3,4,6) "Num" DataName [(GHC_7_4, "GHC.Prim.~# * ($a) Int -> Int -> Expr ($a)"), (GHC_7_8, "($a GHC.Prim.~# Int) -> Int -> Expr $a"), (GHC_7_10, "a GHC.Prim.~# Int -> Int -> Expr a")] (allVersions "main:A") (from78 "A.hs@4:3-4:6" "A.hs@4:3-4:26") (allVersions "") (allVersions "binding occurrence") + assertIdInfo session "A" (4,23,4,26) "Int" TcClsName "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Int" "wired in to the compiler" + assertIdInfo' session "A" (7,3,7,7) (7,3,7,7) "Cond" DataName (allVersions "Expr Bool -> Expr a -> Expr a -> Expr a") (allVersions "main:A") (from78 "A.hs@7:3-7:7" "A.hs@7:3-7:60") (allVersions "") (allVersions "binding occurrence") + assertIdInfo session "A" (7,18,7,19) "a" TvName "" "main:A" "A.hs@7:18-7:19" "" "binding occurrence" + assertIdInfo' session "A" (7,54,7,58) (7,54,7,58) "Expr" TcClsName [] (allVersions "main:A") (from78 "A.hs@3:6-3:10" "A.hs@3:1-7:60") (allVersions "") (allVersions "defined locally") + assertIdInfo session "A" (7,59,7,60) "a" TvName "" "main:A" "A.hs@7:18-7:19" "" "defined locally" + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "{-# LANGUAGE GADTs, KindSignatures, RankNTypes #-}" + , "module A where" + + , "data Expr :: * -> * where" + , " Num :: Int -> Expr Int" + , " Bool :: Bool -> Expr Bool" + , " Add :: Expr Int -> Expr Int -> Expr Int" + , " Cond :: forall a. Expr Bool -> Expr a -> Expr a -> Expr a" + ] + +testOtherTypes :: TestSuiteEnv -> Assertion +testOtherTypes env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + -- TODO: we don't get location info for the fundeps + -- (this is missing from GHC's AST) + assertIdInfo' session "A" (3,7,3,8) (3,7,3,8) "C" TcClsName [] (allVersions "main:A") (from78 "A.hs@3:7-3:8" "A.hs@3:1-4:16") (allVersions "") (allVersions "binding occurrence") + assertIdInfo session "A" (3,9,3,10) "a" TvName "" "main:A" "A.hs@3:9-3:10" "" "binding occurrence" + assertIdInfo' session "A" (4,3,4,4) (4,3,4,4) "f" VarName [] (allVersions "main:A") (from78 "A.hs@4:3-4:4" "A.hs@4:3-4:16") (allVersions "") (allVersions "defined locally") + assertIdInfo session "A" (4,8,4,11) "Int" TcClsName "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Int" "wired in to the compiler" + assertIdInfo session "A" (4,15,4,16) "a" TvName "" "main:A" "A.hs@3:9-3:10" "" "defined locally" + assertIdInfo' session "A" (5,7,5,8) (5,7,5,8) "D" TcClsName [] (allVersions "main:A") (from78 "A.hs@5:7-5:8" "A.hs@5:1-6:14") (allVersions "") (allVersions "binding occurrence") + assertIdInfo session "A" (5,9,5,10) "a" TvName "" "main:A" "A.hs@5:9-5:10" "" "binding occurrence" + assertIdInfo session "A" (5,11,5,12) "b" TvName "" "main:A" "A.hs@5:11-5:12" "" "binding occurrence" + assertIdInfo' session "A" (6,3,6,4) (6,3,6,4) "g" VarName [] (allVersions "main:A") (from78 "A.hs@6:3-6:4" "A.hs@6:3-6:14") (allVersions "") (allVersions "defined locally") + assertIdInfo session "A" (6,8,6,9) "a" TvName "" "main:A" "A.hs@5:9-5:10" "" "defined locally" + assertIdInfo session "A" (6,13,6,14) "b" TvName "" "main:A" "A.hs@5:11-5:12" "" "defined locally" + assertIdInfo' session "A" (7,6,7,9) (7,6,7,9) "Foo" TcClsName [] (allVersions "main:A") (from78 "A.hs@7:6-7:9" "A.hs@7:1-7:15") (allVersions "") (allVersions "binding occurrence") + assertIdInfo session "A" (7,12,7,15) "Int" TcClsName "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Int" "wired in to the compiler" + assertIdInfo' session "A" (8,13,8,16) (8,13,8,16) "Bar" TcClsName [] (allVersions "main:A") (from78 "A.hs@8:13-8:16" "A.hs@8:1-8:18") (allVersions "") (allVersions "binding occurrence") + assertIdInfo session "A" (8,17,8,18) "a" TvName "" "main:A" "A.hs@8:17-8:18" "" "binding occurrence" + assertIdInfo' session "A" (9,15,9,18) (9,15,9,18) "Bar" TcClsName [] (allVersions "main:A") (from78 "A.hs@8:13-8:16" "A.hs@8:1-8:18") (allVersions "") (allVersions "defined locally") + assertIdInfo session "A" (9,19,9,22) "Int" TcClsName "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Int" "wired in to the compiler" + assertIdInfo session "A" (9,25,9,29) "Bool" TcClsName "" "ghc-prim-0.2.0.0:GHC.Types" "" "base-4.5.1.0:Data.Bool" "wired in to the compiler" + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ {- 1 -} "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeFamilies #-}" + , {- 2 -} "module A where" + + , {- 3 -} "class C a where" + , {- 4 -} " f :: Int -> a" + + , {- 5 -} "class D a b | a -> b where" + , {- 6 -} " g :: a -> b" + + , {- 7 -} "type Foo = Int" + + , {- 8 -} "type family Bar a" + , {- 9 -} "type instance Bar Int = Bool" + ] + +testDefaultMethods :: TestSuiteEnv -> Assertion +testDefaultMethods env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + assertIdInfo session "A" (4,11,4,15) "succ" VarName "Enum a1 => a1 -> a1" "base-4.5.1.0:GHC.Enum" "" "base-4.5.1.0:Prelude" "imported from base-4.5.1.0:Prelude at A.hs@1:8-1:9" + where + upd = updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + , "class Foo a where" + , " foo :: a -> Int" + , " foo _ = succ 1" + ] + +testUpdatedSession :: TestSuiteEnv -> Assertion +testUpdatedSession env = withAvailableSession env $ \session -> do + updateSessionD session upd1 1 + assertNoErrors session + assertIdInfo session "Main" (1,14,1,17) "foo" VarName "Integer" "main:Main" "Main.hs@2:1-2:4" "" "defined locally" + + updateSessionD session upd2 1 + assertNoErrors session + assertIdInfo session "Main" (1,14,1,17) "foo" VarName "Integer" "main:Main" "Main.hs@3:1-3:4" "" "defined locally" + where + upd1 = updateSourceFile "Main.hs" "main = print foo\nfoo = 5" + upd2 = updateSourceFile "Main.hs" "main = print foo\n\nfoo = 5" + +testSpanInfoVsExpTypes :: TestSuiteEnv -> Assertion +testSpanInfoVsExpTypes env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + errs <- getSourceErrors session + + case errs of + [] -> do + -- Check the polymorphic type of getNum + assertIdInfo session "A" (6, 8, 6, 14) "getNum" VarName "Stream s m2 Char => s -> m2 (Either ParseError Char)" "main:A" "A.hs@7:9-7:15" "" "defined locally" + assertIdInfo session "A" (6, 31, 6, 37) "getNum" VarName "Stream s m2 Char => s -> m2 (Either ParseError Char)" "main:A" "A.hs@7:9-7:15" "" "defined locally" + assertIdInfo session "A" (7, 9, 7, 15) "getNum" VarName "Stream s m2 Char => s -> m2 (Either ParseError Char)" "main:A" "A.hs@7:9-7:15" "" "binding occurrence" + + -- Check the monomorphic (local) type of getNum + expTypes <- getExpTypes session + assertExpTypes expTypes "A" (6, 8, 6, 14) [ + (6, 7, 6, 58, "(m (Either ParseError Char), m1 (Either ParseError Char))") + , (6, 8, 6, 14, "String -> m (Either ParseError Char)") + , (6, 8, 6, 14, "Stream s m2 Char => s -> m2 (Either ParseError Char)") + , (6, 8, 6, 30, "m (Either ParseError Char)") + ] + assertExpTypes expTypes "A" (6, 31, 6, 37) [ + (6, 7, 6, 58, "(m (Either ParseError Char), m1 (Either ParseError Char))") + , (6, 31, 6, 37, "ByteString -> m1 (Either ParseError Char)") + , (6, 31, 6, 37, "Stream s m2 Char => s -> m2 (Either ParseError Char)") + , (6, 31, 6, 57, "m1 (Either ParseError Char)") + ] + assertExpTypes expTypes "A" (7, 9, 7, 15) [ + (7, 9, 7, 15, "s -> m2 (Either ParseError Char)") + ] + + -- For completeness' sake, check polymorphic type of foo + assertIdInfo session "A" (6, 1, 6, 4) "foo" VarName "(Monad m1, Monad m) => (m (Either ParseError Char), m1 (Either ParseError Char))" "main:A" "A.hs@6:1-6:4" "" "binding occurrence" + _ -> + skipTest "Probably parsec package not installed" + where + upd = updateSourceFile "A.hs" . L.unlines $ [ + "{-# LANGUAGE NoMonomorphismRestriction #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module A where" + , "import Data.ByteString" + , "import Text.Parsec" + -- 1 2 3 4 5 6 + -- 123456789012345 67 890123456789012345678 90 123456789012345678901 + , {- 6 -} "foo = (getNum (\"x\" :: String),getNum (\"x\" :: ByteString))" + -- 1 2 3 4 + -- 1234567890123456789012345678901234567 890123 4 + , {- 7 -} " where getNum = runParserT digit () \"x.txt\"" + ] + +-- TODO: Currently we mark this session as dont reuse because +-- hiding all packages leaves the session unuseable (see #224) +test_StateOfCacheThroughoutUpdates :: TestSuiteEnv -> Assertion +test_StateOfCacheThroughoutUpdates env = withAvailableSession' env (dontReuse . withGhcOpts packageOpts) $ \sess -> do + let cb = \_ -> return () + update = flip (updateSession sess) cb + updMod = \mod code -> updateSourceFile mod (L.fromString code) + + update $ updateCodeGeneration True + update $ updateStdoutBufferMode (RunLineBuffering Nothing) + update $ updateStderrBufferMode (RunLineBuffering Nothing) + + update $ updMod "Foo.hs" $ unlines [ + "module Foo where" + , "" + , "import Bar" + , "" + , "foo = bar >> bar" + , "" + , "foobar = putStrLn \"Baz\"" + ] + + update $ updMod "Bar.hs" $ unlines [ + "module Bar where" + , "" + , "bar = putStrLn \"Hello, world!\"" + ] + assertIdInfo sess "Bar" (3, 7, 3, 15) "putStrLn" VarName "String -> IO ()" "base-4.5.1.0:System.IO" "" "base-4.5.1.0:System.IO" "imported from base-4.5.1.0:Prelude at Bar.hs@1:8-1:11" + + update $ updMod "Baz.hs" $ unlines [ + "module Baz where" + , "" + , "import Foo" + , "import Bar" + , "" + , "baz = foobar" + ] + + assertNoErrors sess + assertIdInfo sess "Bar" (3, 7, 3, 15) "putStrLn" VarName "String -> IO ()" "base-4.5.1.0:System.IO" "" "base-4.5.1.0:System.IO" "imported from base-4.5.1.0:Prelude at Bar.hs@1:8-1:11" + assertIdInfo sess "Baz" (6, 7, 6, 13) "foobar" VarName "IO ()" "main:Foo" "Foo.hs@7:1-7:7" "" "imported from main:Foo at Baz.hs@3:1-3:11" + + update $ updMod "Baz.hs" $ unlines [ + "module Baz where" + , "" + , "import Foo" + , "import Bar" + , "" + , "baz = foobar >>>> foo >> bar" + ] + + assertOneError sess + assertIdInfo sess "Bar" (3, 7, 3, 15) "putStrLn" VarName "String -> IO ()" "base-4.5.1.0:System.IO" "" "base-4.5.1.0:System.IO" "imported from base-4.5.1.0:Prelude at Bar.hs@1:8-1:11" + -- Baz is broken at this point + + update $ updMod "Baz.hs" $ unlines [ + "module Baz where" + , "" + , "import Foo" + , "import Bar" + , "" + , "baz = foobar >> foo >> bar" + ] + + assertNoErrors sess + assertIdInfo sess "Bar" (3, 7, 3, 15) "putStrLn" VarName "String -> IO ()" "base-4.5.1.0:System.IO" "" "base-4.5.1.0:System.IO" "imported from base-4.5.1.0:Prelude at Bar.hs@1:8-1:11" + assertIdInfo sess "Baz" (6, 7, 6, 13) "foobar" VarName "IO ()" "main:Foo" "Foo.hs@7:1-7:7" "" "imported from main:Foo at Baz.hs@3:1-3:11" + where + packageOpts = [ "-hide-all-packages" + , "-package base" + ] + +test_SubExp_Simple :: TestSuiteEnv -> Assertion +test_SubExp_Simple env = withAvailableSession' env (withGhcOpts ["-XNoMonomorphismRestriction"]) $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + -- TODO: the order of these "dominators" seems rather random! + expTypes <- getExpTypes session + assertExpTypes expTypes "A" (2, 6, 2, 6) [ + (2, 6, 2, 8, "Bool -> Bool") + , (2, 6, 2, 8, "a -> a") + , (2, 6, 2, 13, "Bool") + ] + assertExpTypes expTypes "A" (2, 9, 2, 13) [ + (2, 6, 2, 13, "Bool") + , (2, 9, 2, 13, "Bool") + ] + assertExpTypes expTypes "A" (3, 7, 3, 7) [ + (3, 6, 3, 38, "Float") + , (3, 7, 3, 19, "Int -> Float") + , (3, 7, 3, 19, "(Integral a, Num b) => a -> b") + ] + assertExpTypes expTypes "A" (3, 37, 3, 37) [ + (3, 6, 3, 38, "Float") + , (3, 37, 3, 38, "Int") + ] + assertExpTypes expTypes "A" (4, 7, 4, 7) [ + (4, 6, 4, 13, "t -> t") + , (4, 7, 4, 8, "t") + ] + assertExpTypes expTypes "A" (5, 25, 5, 25) [ + (5, 6, 5, 32, "()") + , (5, 24, 5, 27, "Bool -> ()") + , (5, 24, 5, 27, "t -> ()") + , (5, 24, 5, 32, "()") + ] + assertExpTypes expTypes "A" (6, 12, 6, 13) [ + (6, 12, 6, 13, "t") + ] + assertExpTypes expTypes "A" (7, 12, 7, 13) [ + (7, 12, 7, 13, "t1") + ] + assertExpTypes expTypes "A" (8, 12, 8, 13) [ + (8, 12, 8, 13, "t2") + ] + assertExpTypes expTypes "A" (9, 30, 9, 31) [ + (9, 16, 9, 50, "(t, t)") + , (9, 17, 9, 32, "t") + , (9, 24, 9, 31, "t") + , (9, 30, 9, 31, "t2") + ] + assertExpTypes expTypes "A" (9, 35, 9, 36) [ + (9, 16, 9, 50, "(t, t)") + , (9, 34, 9, 49, "t") + , (9, 35, 9, 36, "t1") + , (9, 35, 9, 42, "t") + ] + assertExpTypes expTypes "A" (10, 8, 10, 11) [ + (10, 7, 10, 19, "(Char, [Char])") + , (10, 8, 10, 11, "Char") + ] + assertExpTypes expTypes "A" (10, 13, 10, 18) [ + (10, 7, 10, 19, "(Char, [Char])") + , (10, 13, 10, 18, "[Char]") + ] + assertExpTypes expTypes "A" (11, 10, 11, 14) [ + (11, 7, 11, 48, "IO Int") + , (11, 10, 11, 14, "String") + ] + + -- length has a more general type from ghc 7.10 and up + if testSuiteEnvGhcVersion env < GHC_7_10 + then + assertExpTypes expTypes "A" (11, 36, 11, 42) [ + (11, 7, 11, 48, "IO Int") + , (11, 28, 11, 48, "IO Int") + , (11, 36, 11, 42, "[Char] -> Int") + , (11, 36, 11, 42, "[a] -> Int") + , (11, 36, 11, 47, "Int") + ] + else + assertExpTypes expTypes "A" (11, 36, 11, 42) [ + (11, 7, 11, 48, "IO Int") + , (11, 28, 11, 48, "IO Int") + , (11, 36, 11, 42, "[Char] -> Int") + , (11, 36, 11, 42, "Foldable t => forall a. t a -> Int") + , (11, 36, 11, 47, "Int") + ] + + assertExpTypes expTypes "A" (12, 8, 12, 12) [ + (12, 7, 12, 20, "[Bool]") + , (12, 8, 12, 12, "Bool") + ] + assertExpTypes expTypes "A" (13, 8, 13, 9) [ + (13, 7, 13, 13, "[t]") + , (13, 8, 13, 9, "t") + ] + assertExpTypes expTypes "A" (18, 7, 18, 18) [ + (18, 7, 18, 18, "Bool -> Int -> MyRecord") + , (18, 7, 18, 38, "MyRecord") + ] + assertExpTypes expTypes "A" (18, 21, 18, 22) [ + (18, 7, 18, 38, "MyRecord") + , (18, 21, 18, 22, "Bool") + ] + assertExpTypes expTypes "A" (18, 35, 18, 36) [ + (18, 7, 18, 38, "MyRecord") + , (18, 35, 18, 36, "Int") + ] + assertExpTypes expTypes "A" (19, 13, 19, 14) [ + (19, 7, 19, 20, "MyRecord") + , (19, 13, 19, 14, "Int") + ] + assertExpTypes expTypes "A" (21, 29, 21, 32) [ + (21, 7, 21, 34, "MyPolyRecord Char") + , (21, 29, 21, 32, "Char") + ] + assertExpTypes expTypes "A" (21, 7, 21, 22) [ + (21, 7, 21, 22, "Char -> MyPolyRecord Char") + , (21, 7, 21, 22, "a -> MyPolyRecord a") + , (21, 7, 21, 34, "MyPolyRecord Char") + ] + assertExpTypes expTypes "A" (22, 13, 22, 14) [ + (22, 7, 22, 22, "MyPolyRecord Char") + , (22, 13, 22, 14, "Char") + ] + -- the "MyRecordCon" apparently is not really recorded as such in the + -- AST, we don't get type information about it + assertExpTypes expTypes "A" (23, 19, 23, 30) [ + (23, 7, 23, 39, "Int") + ] + assertExpTypes expTypes "A" (24, 35, 24, 36) [ + (24, 7, 24, 41, "Char") + , (24, 35, 24, 36, "Char") + ] + assertExpTypes expTypes "A" (25, 24, 25, 25) [ + (25, 9, 26, 36, "Maybe a") + , (25, 24, 25, 25, "t") + ] + assertExpTypes expTypes "A" (26, 25, 26, 26) [ + (25, 9, 26, 36, "Maybe a") + , (26, 25, 26, 26, "a") + ] + assertExpTypes expTypes "A" (27, 23, 27, 24) [ + (27, 13, 27, 31, "t") + , (27, 23, 27, 24, "t") + ] + assertExpTypes expTypes "A" (28, 8, 28, 13) [ + (28, 8, 28, 13, "a -> [a]") + , (28, 8, 28, 13, "Enum a1 => a1 -> [a1]") + , (28, 8, 28, 16, "Int -> a") + ] + -- [a1] -> Int -> [a1] is the polymorphic type of (!!), + -- [a] -> Int -> [a] is the "monomorphic" instance (with type vars) + assertExpTypes expTypes "A" (29, 8, 29, 10) [ + (29, 8, 29, 10, "[a] -> Int -> a") + , (29, 8, 29, 10, "[a1] -> Int -> a1") + , (29, 8, 29, 12, "[a] -> a") + ] + -- The 'negation' isn't a proper operator and therefore doesn't get its + -- own type + assertExpTypes expTypes "A" (30, 9, 30, 10) [ + (30, 9, 30, 12, "a") + ] + where + upd = (updateSourceFile "A.hs" . L.unlines $ + [ "module A where" + -- Single type var inst, boolean literal + -- 123456789012 + , {- 2 -} "t2 = id True" + -- Double type var inst, double evidence app, overloaded lit + -- 1234567890123456789012345678901234567 + , {- 3 -} "t3 = (fromIntegral :: Int -> Float) 1" + -- Lambda + -- 12345 6789012 + , {- 4 -} "t4 = \\x -> x" + -- Let + -- 1234567890123456789012345678901 + , {- 5 -} "t5 = let foo x = () in foo True" + -- Type variables + -- 123456789012 + , {- 6 -} "t6 x y z = x" + , {- 7 -} "t7 x y z = y" + , {- 8 -} "t8 x y z = z" + -- Brackets, tuples, operators + -- 0 1 2 3 4 + -- 1234567890123456789012345678901234567890123456789 + , {- 9 -} "t9 f g x y z = (x `f` (y `g` z), (x `f` y) `g` z)" + -- Literals + -- 123456789012 3456 78 + , {- 10 -} "t10 = ('a', \"foo\")" + -- Do expression + -- 0 1 2 3 4 + -- 12345678901234567890123456789012345678901234567 + , {- 11 -} "t11 = do line <- getLine ; return (length line)" + -- Lists + -- 1234567890123456789 + , {- 12 -} "t12 = [True, False]" + , {- 13 -} "t13 = [1, 2]" + -- Records + , "data MyRecord = MyRecordCon {" + , " a :: Bool" + , " , b :: Int" + , " }" + -- 0 1 2 3 4 + -- 1234567890123456789012345678901234567 + , {- 18 -} "t18 = MyRecordCon { a = True, b = 5 }" + -- Record update + , {- 19 -} "t19 = t18 { b = 6 }" + -- Polymorphic records + , "data MyPolyRecord a = MyPolyRecordCon { c :: a }" + -- 0 1 2 3 + -- 123456789012345678901234567890123 + , {- 21 -} "t21 = MyPolyRecordCon { c = 'a' }" + , {- 22 -} "t22 = t21 { c = 'b' }" + -- Case statements, underscore + -- 0 1 2 3 4 + -- 1234567890123456789012345678901234567890 + , {- 23 -} "t23 = case t18 of MyRecordCon a b -> b" + , {- 24 -} "t24 = case t21 of MyPolyRecordCon c -> c" + , {- 25 -} "t25 x = case x of Left _ -> Nothing" + , {- 26 -} " Right y -> Just y" + -- If statement + -- 0 1 2 3 + -- 123456789012345678901234567890 + , {- 27 -} "t27 x y z = if x then y else z" + -- Sections, arithmetic sequences + -- 1234567890123456 + , {- 28 -} "t28 = ([1..] !!)" + , {- 29 -} "t29 = (!! 0)" + -- Negation + -- 12345678901 + , {- 30 -} "t30 x = - x" + ]) + +test_SubExp_TH :: TestSuiteEnv -> Assertion +test_SubExp_TH env = withAvailableSession' env (withGhcOpts ["-XNoMonomorphismRestriction", "-XTemplateHaskell"]) $ \session -> do + updateSessionD session upd 2 + assertNoErrors session + + expTypes <- getExpTypes session + -- The AST doesn't really give us a means to extract the type of + -- a bracket expression :( And we get no info about the lifted vars + assertExpTypes expTypes "A" (3, 9, 3, 20) [] + assertExpTypes expTypes "A" (4, 9, 4, 20) [] + assertExpTypes expTypes "A" (5, 17, 5, 18) [] + -- We don't return types for types, so check the expr splice only + assertExpTypes expTypes "B" (3, 6, 3, 12) [ + (3, 6, 3, 12, "Bool") + ] + -- The typechecked tree contains the expanded splice, but the location + -- of every term in the splice is set to the location of the entire + -- splice + assertExpTypes expTypes "B" (4, 8, 4, 13) [ + (4, 8, 4, 22, "[Char]") + , (4, 8, 4, 22, "[Char]") + , (4, 8, 4, 22, "Char -> [Char] -> [Char]") + , (4, 8, 4, 22, "a -> [a] -> [a]") + , (4, 8, 4, 22, "Char") + ] + where + upd = (updateSourceFile "A.hs" . L.unlines $ + [ {- 1 -} "module A where" + , {- 2 -} "import Language.Haskell.TH.Syntax" + -- Quotations (expressions, types) + -- 1234567890123456789 + , {- 3 -} "qTrue = [| True |]" + , {- 4 -} "qBool = [t| Bool |]" + -- 1234567890123456789012345 + , {- 5 -} "qComp x xs = [| x : xs |]" + ]) + <> (updateSourceFile "B.hs" . L.unlines $ + [ {- 1 -} "module B where" + , {- 2 -} "import A" + -- Splices (expressions, types) + -- 123456789012345678901 + , {- 3 -} "t1 = $qTrue :: $qBool" + -- 12345678901234567 890 12 + , {- 4 -} "t2 = $(qComp 'a' \"bc\")" + ]) + <> (updateCodeGeneration True) + +test_SubExp_TypeFamilies :: TestSuiteEnv -> Assertion +test_SubExp_TypeFamilies env = withAvailableSession' env (withGhcOpts ["-XTypeFamilies"]) $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + expTypes <- getExpTypes session + assertExpTypes expTypes "A" (5, 6, 5, 10) [ + (5, 6, 5, 10, "TestTypeFamily ()") + , (5, 6, 5, 10, "Bool") + ] + assertExpTypes expTypes "A" (8, 6, 8, 13) [ + (8, 6, 8, 13, "TestTypeFamily [a]") + , (8, 6, 8, 13, "Maybe a") + , (8, 6, 8, 13, "Maybe a1") + ] + where + upd = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "module A where" + , {- 2 -} "type family TestTypeFamily a" + -- Monomorphic instance + , {- 3 -} "type instance TestTypeFamily () = Bool" + , {- 4 -} "t1 :: TestTypeFamily ()" + -- 123456789 + , {- 5 -} "t1 = True" + -- Polymorphic instance + , {- 6 -} "type instance TestTypeFamily [a] = Maybe a" + , {- 7 -} "t2 :: TestTypeFamily [a]" + -- 123456789012 + , {- 8 -} "t2 = Nothing" + ]) + +test_SubExp_HigherRank :: TestSuiteEnv -> Assertion +test_SubExp_HigherRank env = withAvailableSession' env (withGhcOpts ["-XRank2Types"]) $ \session -> do + -- Note: intentionally using (==) in this test rather than (<=) so that + -- the "definition type" is different from the "usage type" + -- (forall a. Eq a => a -> a -> Bool) vs (forall a. Ord a => a -> a -> Bool) + + updateSessionD session upd 1 + assertNoErrors session + + expTypes <- getExpTypes session + assertExpTypes expTypes "A" (3, 12, 3, 14) [ + (3, 7, 3, 15, "T") + , (3, 11, 3, 15, "Ord a => a -> a -> Bool") + , (3, 11, 3, 15, "a -> a -> Bool") + , (3, 11, 3, 15, "Eq a => a -> a -> Bool") + ] + where + upd = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "module A where" + , {- 2 -} "newtype T = MkT (forall a. Ord a => a -> a -> Bool)" + -- 12345678901234 + , {- 3 -} "teq = MkT (==)" + ]) + +test_SubExp_Sections :: TestSuiteEnv -> Assertion +test_SubExp_Sections env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + expTypes <- getExpTypes session + assertExpTypes expTypes "A" (4, 11, 4, 12) [ + (4, 10, 4, 13, "Int -> Bool -> Char -> ()") + , (4, 10, 4, 18, "Int -> Char -> ()") + ] + assertExpTypes expTypes "A" (5, 13, 5, 14) [ + (5, 10, 5, 15, "Bool -> Char -> ()") + , (5, 12, 5, 15, "Int -> Bool -> Char -> ()") + ] + where + upd = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "module A where" + , {- 2 -} "f :: Int -> Bool -> Char -> ()" + , {- 3 -} "f = undefined" + -- 1234567890123456789 + , {- 4 -} "test1 = (`f` True)" + , {- 5 -} "test2 = (1 `f`)" + ]) + +test_UseSites_GlobalValues :: TestSuiteEnv -> Assertion +test_UseSites_GlobalValues env = withAvailableSession env $ \session -> do + updateSessionD session upd1 2 + assertNoErrors session + + do useSites <- getUseSites session + assertUseSites useSites "A" (3, 1, 3, 2) "f" uses_f + assertUseSites useSites "A" (3, 6, 3, 7) "+" uses_add + assertUseSites useSites "A" (5, 1, 5, 2) "g" uses_g + assertUseSites useSites "B" (4, 1, 4, 2) "h" uses_h + assertUseSites useSites "B" (4, 6, 4, 7) "+" uses_add + assertUseSites useSites "B" (4, 13, 4, 14) "f" uses_f + assertUseSites useSites "B" (4, 17, 4, 18) "g" uses_g + + -- Update B, swap positions of g and f + + updateSessionD session upd2 1 + assertNoErrors session + + do useSites <- getUseSites session + assertUseSites useSites "A" (3, 1, 3, 2) "f" uses_f2 + assertUseSites useSites "A" (3, 6, 3, 7) "+" uses_add + assertUseSites useSites "A" (5, 1, 5, 2) "g" uses_g2 + assertUseSites useSites "B" (4, 1, 4, 2) "h" uses_h + assertUseSites useSites "B" (4, 6, 4, 7) "+" uses_add + assertUseSites useSites "B" (4, 13, 4, 14) "g" uses_g2 + assertUseSites useSites "B" (4, 17, 4, 18) "f" uses_f2 + + -- Update A, remove one internal use of f, and shift the other + + updateSessionD session upd3 2 + assertNoErrors session + + do useSites <- getUseSites session + assertUseSites useSites "A" (3, 1, 3, 2) "f" uses_f3 + assertUseSites useSites "A" (3, 6, 3, 7) "+" uses_add3 + assertUseSites useSites "A" (5, 1, 5, 2) "g" uses_g2 + assertUseSites useSites "B" (4, 1, 4, 2) "h" uses_h + assertUseSites useSites "B" (4, 6, 4, 7) "+" uses_add3 + assertUseSites useSites "B" (4, 13, 4, 14) "g" uses_g2 + assertUseSites useSites "B" (4, 17, 4, 18) "f" uses_f3 + where + upd1 = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "module A where" + -- 123456789012345 + , {- 2 -} "f :: Int -> Int" + , {- 3 -} "f = (+ 1)" + , {- 4 -} "g :: Int -> Int" + , {- 5 -} "g = f . f" + ]) + <> (updateSourceFile "B.hs" . L.unlines $ [ + {- 1 -} "module B where" + , {- 2 -} "import A" + , {- 3 -} "h :: Int -> Int" + , {- 4 -} "h = (+ 1) . f . g" + ]) + upd2 = (updateSourceFile "B.hs" . L.unlines $ [ + {- 1 -} "module B where" + , {- 2 -} "import A" + , {- 3 -} "h :: Int -> Int" + , {- 4 -} "h = (+ 1) . g . f" + ]) + upd3 = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "module A where" + -- 123456789012345 + , {- 2 -} "f :: Int -> Int" + , {- 3 -} "f = (+ 1)" + , {- 4 -} "g :: Int -> Int" + , {- 5 -} "g = (+ 1) . f" + ]) + + + uses_f = [ + "A.hs@5:9-5:10" + , "A.hs@5:5-5:6" + , "B.hs@4:13-4:14" + ] + uses_add = [ -- "+" + "A.hs@3:6-3:7" + , "B.hs@4:6-4:7" + ] + uses_g = [ + "B.hs@4:17-4:18" + ] + uses_h = [ + ] + + uses_f2 = [ + "A.hs@5:9-5:10" + , "A.hs@5:5-5:6" + , "B.hs@4:17-4:18" + ] + uses_g2 = [ + "B.hs@4:13-4:14" + ] + + uses_f3 = [ + "A.hs@5:13-5:14" + , "B.hs@4:17-4:18" + ] + uses_add3 = [ -- "+" + "A.hs@5:6-5:7" + , "A.hs@3:6-3:7" + , "B.hs@4:6-4:7" + ] + +test_UseSites_Types :: TestSuiteEnv -> Assertion +test_UseSites_Types env = withAvailableSession env $ \session -> do + -- This test follows the same structure as "Use sites 1", but + -- tests types rather than values + + updateSessionD session upd1 2 + assertNoErrors session + + do useSites <- getUseSites session + assertUseSites useSites "A" (2, 6, 2, 7) "F" uses_F + assertUseSites useSites "A" (2, 14, 2, 17) "Int" uses_Int + assertUseSites useSites "A" (3, 6, 3, 7) "G" uses_G + assertUseSites useSites "B" (3, 6, 3, 7) "H" uses_H + assertUseSites useSites "B" (3, 14, 3, 17) "Int" uses_Int + assertUseSites useSites "B" (3, 18, 3, 19) "F" uses_F + assertUseSites useSites "B" (3, 20, 3, 21) "G" uses_G + + -- Update B, swap positions of g and f + + updateSessionD session upd2 1 + assertNoErrors session + + do useSites <- getUseSites session + assertUseSites useSites "A" (2, 6, 2, 7) "F" uses_F2 + assertUseSites useSites "A" (2, 14, 2, 17) "Int" uses_Int + assertUseSites useSites "A" (3, 6, 3, 7) "G" uses_G2 + assertUseSites useSites "B" (3, 6, 3, 7) "H" uses_H + assertUseSites useSites "B" (3, 14, 3, 17) "Int" uses_Int + assertUseSites useSites "B" (3, 18, 3, 19) "G" uses_G2 + assertUseSites useSites "B" (3, 20, 3, 21) "F" uses_F2 + + -- Update A, remove one internal use of f, and shift the other + + updateSessionD session upd3 2 + assertNoErrors session + + do useSites <- getUseSites session + assertUseSites useSites "A" (2, 6, 2, 7) "F" uses_F3 + assertUseSites useSites "A" (2, 14, 2, 17) "Int" uses_Int3 + assertUseSites useSites "A" (3, 6, 3, 7) "G" uses_G2 + assertUseSites useSites "B" (3, 6, 3, 7) "H" uses_H + assertUseSites useSites "B" (3, 14, 3, 17) "Int" uses_Int3 + assertUseSites useSites "B" (3, 18, 3, 19) "G" uses_G2 + assertUseSites useSites "B" (3, 20, 3, 21) "F" uses_F3 + where + upd1 = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "module A where" + -- 1234567890123456 + , {- 2 -} "data F = MkF Int" + , {- 3 -} "data G = MkG F F" + ]) + <> (updateSourceFile "B.hs" . L.unlines $ [ + {- 1 -} "module B where" + , {- 2 -} "import A" + -- 12345678901234567890 + , {- 3 -} "data H = MkH Int F G" + ]) + upd2 = (updateSourceFile "B.hs" . L.unlines $ [ + {- 1 -} "module B where" + , {- 2 -} "import A" + -- 12345678901234567890 + , {- 3 -} "data H = MkH Int G F" + ]) + upd3 = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "module A where" + -- 123456789012345678 + , {- 2 -} "data F = MkF Int" + , {- 3 -} "data G = MkG Int F" + ]) + + uses_F = [ + "A.hs@3:16-3:17" + , "A.hs@3:14-3:15" + , "B.hs@3:18-3:19" + ] + uses_Int = [ + "A.hs@2:14-2:17" + , "B.hs@3:14-3:17" + ] + uses_G = [ + "B.hs@3:20-3:21" + ] + uses_H = [ + ] + + uses_F2 = [ + "A.hs@3:16-3:17" + , "A.hs@3:14-3:15" + , "B.hs@3:20-3:21" + ] + uses_G2 = [ + "B.hs@3:18-3:19" + ] + + uses_F3 = [ + "A.hs@3:18-3:19" + , "B.hs@3:20-3:21" + ] + uses_Int3 = [ + "A.hs@3:14-3:17" + , "A.hs@2:14-2:17" + , "B.hs@3:14-3:17" + ] + +test_UseSites_Local :: TestSuiteEnv -> Assertion +test_UseSites_Local env = withAvailableSession' env (withGhcOpts ["-XScopedTypeVariables"]) $ \session -> do + updateSessionD session upd1 2 + assertNoErrors session + useSites <- getUseSites session + + -- where-bound + do let uses_f = [ + "A.hs@7:14-7:15" + , "A.hs@7:10-7:11" + , "A.hs@2:16-2:17" + ] + uses_add = [ -- "+" + "A.hs@5:11-5:12" + , "A.hs@2:9-2:10" + ] + uses_g = [ + "A.hs@2:20-2:21" + ] + + assertUseSites useSites "A" (5, 6, 5, 7) "f" uses_f + assertUseSites useSites "A" (5, 11, 5, 12) "+" uses_add + assertUseSites useSites "A" (7, 6, 7, 7) "g" uses_g + + -- function args, lambda bound, let bound, case bound + do let uses_f = ["A.hs@8:22-8:23"] + uses_x = ["A.hs@8:24-8:25"] + uses_a = ["A.hs@9:31-9:32"] + uses_b = ["A.hs@9:39-9:40","A.hs@9:35-9:36"] + uses_c = ["A.hs@10:30-10:31","A.hs@10:26-10:27"] + + assertUseSites useSites "A" (8, 7, 8, 8) "f" uses_f + assertUseSites useSites "A" (8, 12, 8, 13) "x" uses_x + assertUseSites useSites "A" (9, 14, 9, 15) "a" uses_a + assertUseSites useSites "A" (9, 35, 9, 36) "b" uses_b -- using def site for variety + assertUseSites useSites "A" (9, 27, 9, 28) "c" uses_c + + -- type args + do let uses_a = ["A.hs@11:20-11:21","A.hs@11:18-11:19"] + uses_b = ["A.hs@11:22-11:23"] + + assertUseSites useSites "A" (11, 18, 11, 19) "a" uses_a + assertUseSites useSites "A" (11, 10, 11, 11) "b" uses_b + + -- implicit forall + do let uses_a = ["A.hs@12:16-12:17","A.hs@12:6-12:7"] + uses_b = ["A.hs@12:11-12:12"] + + assertUseSites useSites "A" (12, 6, 12, 7) "a" uses_a + assertUseSites useSites "A" (12, 11, 12, 12) "b" uses_b + + -- explicit forall + do let uses_a = ["A.hs@14:28-14:29","A.hs@14:18-14:19"] + uses_b = ["A.hs@14:23-14:24"] + + assertUseSites useSites "A" (14, 13, 14, 14) "a" uses_a + assertUseSites useSites "A" (14, 23, 14, 24) "b" uses_b + where + upd1 = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "module A where" + -- 123456789012345 + , {- 2 -} "test = (+ 1) . f . g" + , {- 3 -} " where" + , {- 4 -} " f :: Int -> Int" + , {- 5 -} " f = (+ 1)" + , {- 6 -} " g :: Int -> Int" + , {- 7 -} " g = f . f" + -- Function args, lambda bound, let bound, case bound + -- 1 2 3 + -- 1234567890 12345678901234567 + , {- 8 -} "test2 f = \\x -> case f x of" + -- 123456789012345678901234567890123456789 + , {- 9 -} " (a, b) -> let c = a * b * b" + , {- 10 -} " in c * c" + -- Type arguments + -- 1234567890123456789012 + , {- 11 -} "data T a b = MkT a a b" + -- Implicit forall + -- 1234567890123456 + , {- 12 -} "f :: a -> b -> a" + , {- 13 -} "f x y = x" + -- Explicit forall + -- 1234567890123456789012345678 + , {- 14 -} "g :: forall a b. a -> b -> a" + , {- 15 -} "g x y = x" + ]) + +{------------------------------------------------------------------------------- + Tests for dealing with HsWrapper +-------------------------------------------------------------------------------} + +test_HsWrapper_WpTyApp :: TestSuiteEnv -> Assertion +test_HsWrapper_WpTyApp env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + expTypes <- getExpTypes session + assertExpTypes expTypes "A" (5,5,5,6) [ + (5,5,5,6, "Int -> Int") -- after type application + , (5,5,5,6, "a -> a") -- polymorphic type + ] + where + upd = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "module A where" + , {- 2 -} "f :: a -> a" + , {- 3 -} "f = undefined" + , {- 4 -} "g :: Int -> Int" + , {- 5 -} "g = f" -- requires WpTyApp + ]) + +test_HsWrapper_WpTyLam :: TestSuiteEnv -> Assertion +test_HsWrapper_WpTyLam env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + expTypes <- getExpTypes session + assertExpTypes expTypes "A" (8,7,8,8) [ + (8,5,8,8,"Int") -- result of application + , (8,7,8,8,"a -> a -> a") -- generalized + , (8,7,8,8,"a -> a -> a") -- instantiated with skolems + , (8,7,8,8,"a -> b -> b") -- poly type of type of g + ] + where + upd = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "{-# LANGUAGE RankNTypes #-}" + , {- 2 -} "module A where" + , {- 3 -} "f :: (forall a. a -> a -> a) -> Int" + , {- 4 -} "f = undefined" + , {- 5 -} "g :: forall a b. a -> b -> b" + , {- 6 -} "g = undefined" + , {- 7 -} "h :: Int" + , {- 8 -} "h = f g" -- requires WpTyApp, WpTyLam + ]) + +test_HsWrapper_WpEvApp :: TestSuiteEnv -> Assertion +test_HsWrapper_WpEvApp env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + expTypes <- getExpTypes session + assertExpTypes expTypes "A" (5,5,5,6) [ + (5,5,5,6,"Int -> Int") -- after type and evidence application + , (5,5,5,6,"Eq a => a -> a") -- original type + ] + where + upd = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "module A where" + , {- 2 -} "f :: Eq a => a -> a" + , {- 3 -} "f = undefined" + , {- 4 -} "g :: Int -> Int" + , {- 5 -} "g = f" -- requires WpTyApp, WpEvApp + ]) + +test_HsWrapper_WpEvLam :: TestSuiteEnv -> Assertion +test_HsWrapper_WpEvLam env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + expTypes <- getExpTypes session + assertExpTypes expTypes "A" (8,7,8,8) [ + (8,5,8,8,"Int") -- Result of application + , (8,7,8,8,"Eq a => a -> a -> a") -- Evidence and type lambdas added + , (8,7,8,8,"a -> a -> a") -- Instantiated + , (8,7,8,8,"(Eq a, Eq b) => a -> b -> b") -- Original polymorphic type + ] + where + upd = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "{-# LANGUAGE RankNTypes #-}" + , {- 2 -} "module A where" + , {- 3 -} "f :: (forall a. Eq a => a -> a -> a) -> Int" + , {- 4 -} "f = undefined" + , {- 5 -} "g :: forall a b. (Eq a, Eq b) => a -> b -> b" + , {- 6 -} "g = undefined" + , {- 7 -} "h :: Int" + , {- 8 -} "h = f g" -- requires WpTyApp, WpTyLam, WpEvApp, WpEvLam, WpLet + ]) + +test_HsWrapper_WpCast :: TestSuiteEnv -> Assertion +test_HsWrapper_WpCast env = withAvailableSession env $ \session -> do + updateSessionD session upd 1 + assertNoErrors session + + expTypes <- getExpTypes session + assertExpTypes expTypes "A" (4,7,4,8) [ + (4,7,4,8,"b") -- after the cast + , (4,7,4,8,"a") -- before the cast + ] + where + upd = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "{-# LANGUAGE GADTs #-}" + , {- 2 -} "module A where" + , {- 3 -} "f :: a ~ b => a -> b" + , {- 4 -} "f x = x" -- requires WpCast + ]) + +test_HsWrapper_WpFun :: TestSuiteEnv -> Assertion +test_HsWrapper_WpFun env = withAvailableSession env $ \session -> do + when (testSuiteEnvGhcVersion env < GHC_7_10) $ + skipTest "Only supported in GHC 7.10 and up" + + updateSessionD session upd 1 + assertNoErrors session + + -- See "Wrinkle 2" in TcUnify in the GHC sources. This example gets + -- elaborated to + -- + -- > f1 = \k -> k @ Int @ Char + -- + -- (this is necessary for full subsumption checking). Prior to GHC 7.10 + -- this example would not type check. + + expTypes <- getExpTypes session + assertExpTypes expTypes "A" (6,6,6,7) [ + (6,6,6,7,"(forall a b. a -> b) -> Int") -- after HsWrap + , (6,6,6,7,"(Int -> Char) -> Int") -- before HsWrap + ] + where + upd = (updateSourceFile "A.hs" . L.unlines $ [ + {- 1 -} "{-# LANGUAGE RankNTypes #-}" + , {- 2 -} "module A where" + , {- 3 -} "g :: (Int -> Char) -> Int" + , {- 4 -} "g = undefined" + , {- 5 -} "f1 :: (forall a b. a -> b) -> Int" + , {- 6 -} "f1 = g" + ]) diff --git a/TestSuite/TestSuite/Tests/UpdateTargets.hs b/TestSuite/TestSuite/Tests/UpdateTargets.hs new file mode 100644 --- /dev/null +++ b/TestSuite/TestSuite/Tests/UpdateTargets.hs @@ -0,0 +1,614 @@ +module TestSuite.Tests.UpdateTargets (testGroupUpdateTargets) where + +import Data.Monoid +import System.Exit +import System.FilePath +import System.Process +import Test.Tasty +import Test.HUnit +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.Text as T + +import IdeSession +import TestSuite.State +import TestSuite.Session +import TestSuite.Assertions + +testGroupUpdateTargets :: TestSuiteEnv -> TestTree +testGroupUpdateTargets env = testGroup "Update targets" [ + stdTest env "[{} < A, {A} < B, {A} < C], require [A]" test_1 + , stdTest env "[{} < A, {A} < B, {A} < C], require [A], error in B" test_2 + , stdTest env "[{} < A, {A} < B, {A} < C], require [B]" test_3 + , stdTest env "[{} < A, {A} < B, {A} < C], require [B], error in C" test_4 + , stdTest env "[{} < A, {A} < B, {A} < C], require [A], error in A" test_5 + , stdTest env "[{} < A, {A} < B, {A} < C], require [B], error in A" test_6 + , stdTest env "[{} < A, {A} < B, {A} < C], require [B], error in B" test_7 + , stdTest env "[{} < A, {A} < B, {A} < C], require [B, C]" test_8 + , stdTest env "[{} < A, {A} < B, {A} < C], require [B, C], then [B]" test_9 + , stdTest env "[{} < A, {A} < B, {A} < C], require [B, C], then [B] with modified B" test_10 + , stdTest env "[{} < A, {A} < B, {A} < C], require [B, C], then [B] with modified B and error in C" test_11 + , stdTest env "[{} < A, {A} < B, {A} < C], require [B, C], then [B] with error in C" test_12 + , stdTest env "Switch from one to another relative include path for the same module name with TargetsInclude" test_Switch_TargetsInclude + , stdTest env "Switch from one to another relative include path for the same module name with TargetsExclude" test_Switch_TargetsExclude + , stdTest env "Switch from one to another relative include path with TargetsInclude and the main module not in path" test_Switch_TargetsInclude_MainNotInPath + ] + +test_1 :: TestSuiteEnv -> Assertion +test_1 env = withAvailableSession env $ \session -> do + updateSessionD session (mconcat [ + modAn "0" + , modBn "0" + , modCn "0" + , updateTargets (TargetsInclude ["A.hs"]) + ]) 1 + assertNoErrors session + assertLoadedModules session "" ["A"] + + buildExeTargetHsSucceeds env session "A" + +test_2 :: TestSuiteEnv -> Assertion +test_2 env = withAvailableSession env $ \session -> do + updateSessionD session (mconcat [ + modAn "0" + , modBn "invalid" + , modCn "0" + , updateTargets (TargetsInclude ["A.hs"]) + ]) 1 + assertNoErrors session + assertLoadedModules session "" ["A"] + + buildExeTargetHsSucceeds env session "A" + +test_3 :: TestSuiteEnv -> Assertion +test_3 env = withAvailableSession env $ \session -> do + updateSessionD session (mconcat [ + modAn "0" + , modBn "0" + , modCn "0" + , updateTargets (TargetsInclude ["B.hs"]) + ]) 2 + assertNoErrors session + assertLoadedModules session "" ["A", "B"] + + buildExeTargetHsSucceeds env session "B" + +test_4 :: TestSuiteEnv -> Assertion +test_4 env = withAvailableSession env $ \session -> do + updateSessionD session (mconcat [ + modAn "0" + , modBn "0" + , modCn "invalid" + , updateTargets (TargetsInclude ["B.hs"]) + ]) 2 + assertNoErrors session + assertLoadedModules session "" ["A", "B"] + + buildExeTargetHsSucceeds env session "B" + buildExeTargetHsFails env session "C" + +test_5 :: TestSuiteEnv -> Assertion +test_5 env = withAvailableSession env $ \session -> do + updateSessionD session (mconcat [ + modAn "invalid" + , modBn "0" + , modCn "0" + , updateTargets (TargetsInclude ["A.hs"]) + ]) 1 + assertOneError session + assertLoadedModules session "" [] + + buildExeTargetHsFails env session "A" + +test_6 :: TestSuiteEnv -> Assertion +test_6 env = withAvailableSession env $ \session -> do + updateSessionD session (mconcat [ + modAn "invalid" + , modBn "0" + , modCn "0" + , updateTargets (TargetsInclude ["B.hs"]) + ]) 2 + assertOneError session + assertLoadedModules session "" [] + + buildExeTargetHsFails env session "B" + +test_7 :: TestSuiteEnv -> Assertion +test_7 env = withAvailableSession env $ \session -> do + updateSessionD session (mconcat [ + modAn "0" + , modBn "invalid" + , modCn "0" + , updateTargets (TargetsInclude ["B.hs"]) + ]) 2 + assertOneError session + assertLoadedModules session "" ["A"] + + buildExeTargetHsFails env session "B" + -- Only fails due to + -- "Source errors encountered. Not attempting to build executables." + -- buildExeTargetHsSucceeds session "A" + +test_8 :: TestSuiteEnv -> Assertion +test_8 env = withAvailableSession env $ \session -> do + updateSessionD session (mconcat [ + modAn "0" + , modBn "0" + , modCn "0" + , updateTargets (TargetsInclude ["B.hs", "C.hs"]) + ]) 3 + assertNoErrors session + assertLoadedModules session "" ["A", "B", "C"] + autocomplete <- getAutocompletion session + assertEqual "we have autocompletion info for C" 2 $ + length (autocomplete "C" "sp") -- span, split + + buildExeTargetHsSucceeds env session "B" + buildExeTargetHsSucceeds env session "C" + +test_9 :: TestSuiteEnv -> Assertion +test_9 env = withAvailableSession env $ \session -> do + updateSessionD session (mconcat [ + modAn "0" + , modBn "0" + , modCn "0" + , updateTargets (TargetsInclude ["B.hs", "C.hs"]) + ]) 3 + assertNoErrors session + assertLoadedModules session "" ["A", "B", "C"] + do autocomplete <- getAutocompletion session + assertEqual "we have autocompletion info for C" 2 $ + length (autocomplete "C" "sp") -- span, split + + buildExeTargetHsSucceeds env session "C" + + updateSessionD session (mconcat [ + updateTargets (TargetsInclude ["B.hs"]) + ]) 2 + assertLoadedModules session "" ["A", "B"] + do autocomplete <- getAutocompletion session + assertEqual "we no longer have autocompletion info for C" 0 $ + length (autocomplete "C" "sp") -- span, split + + buildExeTargetHsSucceeds env session "B" + +test_10 :: TestSuiteEnv -> Assertion +test_10 env = withAvailableSession env $ \session -> do + updateSessionD session (mconcat [ + modAn "0" + , modBn "0" + , modCn "0" + , updateTargets (TargetsInclude ["B.hs", "C.hs"]) + ]) 3 + assertNoErrors session + assertLoadedModules session "" ["A", "B", "C"] + do autocomplete <- getAutocompletion session + assertEqual "we have autocompletion info for C" 2 $ + length (autocomplete "C" "sp") -- span, split + + buildExeTargetHsSucceeds env session "C" + + updateSessionD session (mconcat [ + modBn "1" + , updateTargets (TargetsInclude ["B.hs"]) + ]) 2 + assertLoadedModules session "" ["A", "B"] + do autocomplete <- getAutocompletion session + assertEqual "autocompletion info for C cleared" 0 $ + length (autocomplete "C" "sp") + + buildExeTargetHsSucceeds env session "B" + +test_11 :: TestSuiteEnv -> Assertion +test_11 env = withAvailableSession env $ \session -> do + updateSessionD session (mconcat [ + modAn "0" + , modBn "0" + , modCn "0" + , updateTargets (TargetsInclude ["B.hs", "C.hs"]) + ]) 3 + assertNoErrors session + assertLoadedModules session "" ["A", "B", "C"] + do autocomplete <- getAutocompletion session + assertEqual "we have autocompletion info for C" 2 $ + length (autocomplete "C" "sp") -- span, split + + updateSessionD session (mconcat [ + modBn "1" + , modCn "invalid" + , updateTargets (TargetsInclude ["B.hs"]) + ]) 2 + assertLoadedModules session "" ["A", "B"] + do autocomplete <- getAutocompletion session + assertEqual "autocompletion info for C cleared" 0 $ + length (autocomplete "C" "sp") + + buildExeTargetHsFails env session "C" + buildExeTargetHsSucceeds env session "B" + +test_12 :: TestSuiteEnv -> Assertion +test_12 env = withAvailableSession env $ \session -> do + updateSessionD session (mconcat [ + modAn "0" + , modBn "0" + , modCn "0" + , updateTargets (TargetsInclude ["B.hs", "C.hs"]) + ]) 3 + assertNoErrors session + assertLoadedModules session "" ["A", "B", "C"] + do autocomplete <- getAutocompletion session + assertEqual "we have autocompletion info for C" 2 $ + length (autocomplete "C" "sp") -- span, split + + updateSessionD session (mconcat [ + modCn "invalid" + , updateTargets (TargetsInclude ["B.hs"]) + ]) 2 + assertLoadedModules session "" ["A", "B"] + do autocomplete <- getAutocompletion session + assertEqual "autocompletion info for C cleared" 0 $ + length (autocomplete "C" "sp") + + buildExeTargetHsFails env session "C" + buildExeTargetHsSucceeds env session "B" + +test_Switch_TargetsInclude :: TestSuiteEnv -> Assertion +test_Switch_TargetsInclude env = withAvailableSession env $ \session -> do + loadModulesFrom' session "TestSuite/inputs/AnotherA" (TargetsInclude ["TestSuite/inputs/AnotherA/A.hs"]) + assertOneError session + updateSessionD session (updateCodeGeneration True) 0 + updateSessionD session + (updateSourceFileFromFile "TestSuite/inputs/ABnoError/B.hs") + 0 + assertOneError session + updateSessionD session + (updateSourceFileFromFile "TestSuite/inputs/AnotherB/B.hs") + 0 + assertOneError session + + updateSessionD session + (updateRelativeIncludes ["", "TestSuite/inputs/AnotherA", "TestSuite/inputs/ABnoError"]) + 2 -- note the recompilation + assertNoErrors session + + do runActions <- runStmt session "Main" "main" + (output, _) <- runWaitAll runActions + assertEqual "output" "\"running 'A depends on B, no errors' from ABnoError\"\n" output + + let m = "Main" + distDir <- getDistDir session + ifTestingExe env $ do + let updE = buildExe [] [(T.pack m, "TestSuite/inputs/AnotherA/A.hs")] + updateSessionD session updE 4 -- TODO: Some modules may be compiled more than once (#189) + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + (stExc, out, _) <- + readProcessWithExitCode (distDir "build" m m) [] [] + assertEqual "A throws exception" (ExitFailure 1) stExc + assertEqual "exe output with old include path" + "\"running 'A depends on B, no errors' from ABnoError\"\n" + out + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "\"running 'A depends on B, no errors' from ABnoError\"\nMain: A.hs throws exception\n" + outExe + assertEqual "after runExe" (ExitFailure 1) statusExe + + let updE2 = buildExe [] [(T.pack m, "A.hs")] + updateSessionD session updE2 0 + status2 <- getBuildExeStatus session + assertEqual "after exe build2" (Just ExitSuccess) status2 + (stExc2, out2, _) <- + readProcessWithExitCode (distDir "build" m m) [] [] + assertEqual "A throws exception" (ExitFailure 1) stExc2 + assertEqual "exe output with old include path" + "\"running 'A depends on B, no errors' from ABnoError\"\n" + out2 + runActionsExe2 <- runExe session m + (outExe2, statusExe2) <- runWaitAll runActionsExe2 + assertEqual "Output from runExe 2" + "\"running 'A depends on B, no errors' from ABnoError\"\nMain: A.hs throws exception\n" + outExe2 + assertEqual "after runExe" (ExitFailure 1) statusExe2 + + updateSessionD session + (updateRelativeIncludes ["TestSuite/inputs/AnotherA", "TestSuite/inputs/AnotherB"]) + 2 + assertNoErrors session + + do runActions3 <- runStmt session "Main" "main" + (output3, _) <- runWaitAll runActions3 + assertEqual "output3" "\"running A with another B\"\n" output3 + + updateSessionD session + (updateSourceFileDelete "TestSuite/inputs/ABnoError/B.hs") + 0 -- already recompiled above + assertNoErrors session + + do runActions35 <- runStmt session "Main" "main" + (output35, _) <- runWaitAll runActions35 + assertEqual "output35" "\"running A with another B\"\n" output35 + + -- And this one works OK even without updateSourceFileDelete + -- and even without session restart. + ifTestingExe env $ do + let updE3 = buildExe [] [(T.pack m, "TestSuite/inputs/AnotherA/A.hs")] + updateSessionD session updE3 1 + status3 <- getBuildExeStatus session + -- Path "" no longer in include paths here! + assertEqual "after exe build3" (Just $ ExitFailure 1) status3 + + let updE4 = buildExe [] [(T.pack m, "A.hs")] + updateSessionD session updE4 2 + status4 <- getBuildExeStatus session + assertEqual "after exe build4" (Just ExitSuccess) status4 + (stExc4, out4, _) <- + readProcessWithExitCode (distDir "build" m m) [] [] + assertEqual "A throws exception" (ExitFailure 1) stExc4 + assertEqual "exe output with new include path" + "\"running A with another B\"\n" + out4 + runActionsExe4 <- runExe session m + (outExe4, statusExe4) <- runWaitAll runActionsExe4 + assertEqual "Output from runExe 4" + "\"running A with another B\"\nMain: A.hs throws exception\n" + outExe4 + assertEqual "after runExe" (ExitFailure 1) statusExe4 + +test_Switch_TargetsExclude :: TestSuiteEnv -> Assertion +test_Switch_TargetsExclude env = withAvailableSession env $ \session -> do + loadModulesFrom' session "TestSuite/inputs/AnotherA" (TargetsExclude []) + assertOneError session + + updateSessionD session (updateCodeGeneration True) 0 + updateSessionD session + (updateSourceFileFromFile "TestSuite/inputs/ABnoError/B.hs") + 2 + assertNoErrors session + updateSessionD session + (updateRelativeIncludes ["", "TestSuite/inputs/AnotherA", "TestSuite/inputs/ABnoError"]) + 2 -- with TargetsExclude [], this is superfluous + assertNoErrors session + + do runActions <- runStmt session "Main" "main" + (output, _) <- runWaitAll runActions + assertEqual "output" "\"running 'A depends on B, no errors' from ABnoError\"\n" output + + distDir <- getDistDir session + let m = "Main" + ifTestingExe env $ do + let updE = buildExe [] [(T.pack m, "TestSuite/inputs/AnotherA/A.hs")] + updateSessionD session updE 4 -- TODO: Some modules may be compiled more than once (#189) + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + (stExc, out, _) <- + readProcessWithExitCode (distDir "build" m m) [] [] + assertEqual "A throws exception" (ExitFailure 1) stExc + assertEqual "exe output with old include path" + "\"running 'A depends on B, no errors' from ABnoError\"\n" + out + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe" + "\"running 'A depends on B, no errors' from ABnoError\"\nMain: A.hs throws exception\n" + outExe + assertEqual "after runExe" (ExitFailure 1) statusExe + + let updE2 = buildExe [] [(T.pack m, "A.hs")] + updateSessionD session updE2 0 + status2 <- getBuildExeStatus session + assertEqual "after exe build2" (Just ExitSuccess) status2 + (stExc2, out2, _) <- + readProcessWithExitCode (distDir "build" m m) [] [] + assertEqual "A throws exception" (ExitFailure 1) stExc2 + assertEqual "exe output with old include path" + "\"running 'A depends on B, no errors' from ABnoError\"\n" + out2 + runActionsExe2 <- runExe session m + (outExe2, statusExe2) <- runWaitAll runActionsExe2 + assertEqual "Output from runExe 2" + "\"running 'A depends on B, no errors' from ABnoError\"\nMain: A.hs throws exception\n" + outExe2 + assertEqual "after runExe" (ExitFailure 1) statusExe2 + + updateSessionD session + (updateSourceFileDelete "TestSuite/inputs/ABnoError/B.hs") + 0 + assertOneError session + updateSessionD session + (updateSourceFileFromFile "TestSuite/inputs/AnotherB/B.hs") + 2 + assertNoErrors session + + updateSessionD session + (updateTargets (TargetsInclude ["TestSuite/inputs/AnotherA/A.hs"])) + 0 + assertOneError session + + updateSessionD session + (updateRelativeIncludes ["TestSuite/inputs/AnotherA", "TestSuite/inputs/AnotherB"]) + 2 -- with TargetsExclude, this would be superfluous + assertNoErrors session -- fixed the error from above + updateSessionD session + (updateTargets (TargetsExclude [])) + 2 -- recompilation due to session restart only + assertNoErrors session + + do runActions3 <- runStmt session "Main" "main" + (output3, _) <- runWaitAll runActions3 + assertEqual "output3" "\"running A with another B\"\n" output3 + + ifTestingExe env $ do + let updE3 = buildExe [] [(T.pack m, "TestSuite/inputs/AnotherA/A.hs")] + updateSessionD session updE3 1 + status3 <- getBuildExeStatus session + -- Path "" no longer in include paths here! + assertEqual "after exe build3" (Just $ ExitFailure 1) status3 + + let updE4 = buildExe [] [(T.pack m, "A.hs")] + updateSessionD session updE4 2 + status4 <- getBuildExeStatus session + assertEqual "after exe build4" (Just ExitSuccess) status4 + (stExc4, out4, _) <- + readProcessWithExitCode (distDir "build" m m) [] [] + assertEqual "A throws exception" (ExitFailure 1) stExc4 + assertEqual "exe output with new include path" + "\"running A with another B\"\n" + out4 + runActionsExe4 <- runExe session m + (outExe4, statusExe4) <- runWaitAll runActionsExe4 + assertEqual "Output from runExe 4" + "\"running A with another B\"\nMain: A.hs throws exception\n" + outExe4 + assertEqual "after runExe" (ExitFailure 1) statusExe4 + +test_Switch_TargetsInclude_MainNotInPath :: TestSuiteEnv -> Assertion +test_Switch_TargetsInclude_MainNotInPath env = withAvailableSession env $ \session -> do + -- Since we set the target explicitly, ghc will need to be able to find + -- the other module (B) on its own; that means it will need an include + -- path to /TestSuite/inputs/ABnoError + loadModulesFrom' session "TestSuite/inputs/ABnoError" (TargetsInclude ["TestSuite/inputs/ABnoError/A.hs"]) + assertOneError session + updateSessionD session + (updateSourceFileFromFile "TestSuite/inputs/AnotherB/B.hs") + 0 + assertOneError session + + updateSessionD session (updateCodeGeneration True) 0 + updateSessionD session + (updateRelativeIncludes ["TestSuite/inputs/ABnoError"]) + 2 -- note the recompilation + assertNoErrors session + + runActions <- runStmt session "Main" "main" + (output, _) <- runWaitAll runActions + assertEqual "output" "\"running 'A depends on B, no errors' from ABnoError\"\n" output + + updateSessionD session + (updateRelativeIncludes ["TestSuite/inputs/AnotherB"]) -- A not in path + 2 + assertNoErrors session + + runActions3 <- runStmt session "Main" "main" + (output3, _) <- runWaitAll runActions3 + assertEqual "output3" "\"running A with another B\"\n" output3 + + updateSessionD session + (updateSourceFileDelete "TestSuite/inputs/ABnoError/B.hs") + 0 -- already recompiled above + assertNoErrors session + + do runActions35 <- runStmt session "Main" "main" + (output35, _) <- runWaitAll runActions35 + assertEqual "output35" "\"running A with another B\"\n" output35 + + distDir <- getDistDir session + let m = "Main" + let updE4 = buildExe [] [(T.pack m, "A.hs")] + ifTestingExe env $ do + updateSessionD session updE4 1 + status4 <- getBuildExeStatus session + assertEqual "after exe build4" (Just $ ExitFailure 1) status4 + -- Failure due to no A in path. + + updateSessionD session + (updateRelativeIncludes ["", "TestSuite/inputs/AnotherB"]) -- A still not in path + 2 + assertNoErrors session + + -- buildExe with full paths works though, if the includes have "" + let updE41 = buildExe [] [(T.pack m, "TestSuite/inputs/ABnoError/A.hs")] + ifTestingExe env $ do + updateSessionD session updE41 3 -- TODO: Some modules may be compiled more than once (#189) + status41 <- getBuildExeStatus session + assertEqual "after exe build41" (Just ExitSuccess) status41 + (stExc41, out41, _) <- + readProcessWithExitCode (distDir "build" m m) [] [] + assertEqual "A throws exception" (ExitFailure 1) stExc41 + assertEqual "exe output with new include path" + "\"running A with another B\"\n" + out41 + runActionsExe <- runExe session m + (outExe, statusExe) <- runWaitAll runActionsExe + assertEqual "Output from runExe 41" + "\"running A with another B\"\nMain: A.hs throws exception\n" + outExe + assertEqual "after runExe" (ExitFailure 1) statusExe + + updateSessionD session + (updateRelativeIncludes ["TestSuite/inputs/AnotherB", "TestSuite/inputs/ABnoError"]) -- A again in path + 2 + assertNoErrors session + + do runActions4 <- runStmt session "Main" "main" + (output4, _) <- runWaitAll runActions4 + assertEqual "output4" "\"running A with another B\"\n" output4 + + -- A again in path, so this time this works + ifTestingExe env $ do + updateSessionD session updE4 3 -- TODO: Some modules may be compiled more than once (#189) + status45 <- getBuildExeStatus session + assertEqual "after exe build45" (Just ExitSuccess) status45 + (stExc45, out45, _) <- + readProcessWithExitCode (distDir "build" m m) [] [] + assertEqual "A throws exception" (ExitFailure 1) stExc45 + assertEqual "exe output with new include path" + "\"running A with another B\"\n" + out45 + runActionsExe4 <- runExe session m + (outExe4, statusExe4) <- runWaitAll runActionsExe4 + assertEqual "Output from runExe 45" + "\"running A with another B\"\nMain: A.hs throws exception\n" + outExe4 + assertEqual "after runExe" (ExitFailure 1) statusExe4 + + updateSessionD session + (updateRelativeIncludes ["TestSuite/inputs/ABnoError"]) + 0 + assertOneError session -- correct + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +buildExeTargetHsSucceeds :: TestSuiteEnv -> IdeSession -> String -> IO () +buildExeTargetHsSucceeds env session m = ifTestingExe env $ do + let updE = buildExe [] [(T.pack m, m <.> "hs")] + updateSessionD session updE 5 -- TODO: Main be compiled twice? (#189) + distDir <- getDistDir session + buildStderr <- readFile $ distDir "build/ide-backend-exe.stderr" + assertEqual "buildStderr empty" "" buildStderr + status <- getBuildExeStatus session + assertEqual "after exe build" (Just ExitSuccess) status + +buildExeTargetHsFails :: TestSuiteEnv -> IdeSession -> String -> IO () +buildExeTargetHsFails env session m = ifTestingExe env $ do + let updE = buildExe [] [(T.pack m, m <.> "hs")] + updateSessionD session updE 5 -- TODO: Main be compiled twice? (#189) + status <- getBuildExeStatus session + assertEqual "after exe build" (Just $ ExitFailure 1) status + +modAn, modBn, modCn :: String -> IdeSessionUpdate +modAn n = updateSourceFile "A.hs" $ L.fromString $ unlines [ + "module A (foo, main) where" + , "foo :: Int" + , "foo = " ++ n + , "main :: IO ()" + , "main = return ()" + ] +modBn n = updateSourceFile "B.hs" $ L.fromString $ unlines [ + "module B (bar, main) where" + , "import A (foo)" + , "bar :: Int" + , "bar = foo + " ++ n + , "main :: IO ()" + , "main = return ()" + ] +modCn n = updateSourceFile "C.hs" $ L.fromString $ unlines [ + "module C (baz, main) where" + , "import A (foo)" + , "baz :: Int" + , "baz = foo + " ++ n + , "main :: IO ()" + , "main = return ()" + ] diff --git a/ide-backend-exe-cabal.hs b/ide-backend-exe-cabal.hs new file mode 100644 --- /dev/null +++ b/ide-backend-exe-cabal.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment (getArgs) + +import IdeSession.ExeCabalServer (exeCabalEngine) +import IdeSession.RPC.Server + +main :: IO () +main = do + args <- getArgs + rpcServer exeCabalEngine args diff --git a/ide-backend.cabal b/ide-backend.cabal new file mode 100644 --- /dev/null +++ b/ide-backend.cabal @@ -0,0 +1,259 @@ +name: ide-backend +version: 0.9.0 +synopsis: An IDE backend library +-- description: +license: MIT +license-file: LICENSE +author: Duncan Coutts, Mikolaj Konarski, Edsko de Vries +maintainer: Duncan Coutts +copyright: (c) 2015 FP Complete +data-files: CoreLicenses.txt +category: Development +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: IdeSession + other-modules: IdeSession.State, + IdeSession.Config, + IdeSession.Cabal, + IdeSession.ExeCabalClient, + IdeSession.Licenses, + IdeSession.Query, + IdeSession.Update, + IdeSession.Update.IdeSessionUpdate, + IdeSession.Update.ExecuteSessionUpdate, + IdeSession.RPC.Client, + IdeSession.RPC.API, + IdeSession.RPC.Stream, + IdeSession.Types.Public, + IdeSession.Types.Private, + IdeSession.Types.Translation, + IdeSession.Types.Progress, + IdeSession.GHC.API, + IdeSession.GHC.Requests, + IdeSession.GHC.Responses, + IdeSession.GHC.Client, + IdeSession.Util, + IdeSession.Util.BlockingOps, + IdeSession.Util.PrettyVal, + IdeSession.Strict.Container, + IdeSession.Strict.IntMap, + IdeSession.Strict.List, + IdeSession.Strict.Map, + IdeSession.Strict.Maybe, + IdeSession.Strict.Trie, + IdeSession.Strict.IntervalMap + IdeSession.Strict.MVar + IdeSession.Strict.IORef + IdeSession.Strict.StateT + + build-depends: base ==4.*, + filemanip >= 0.3.6.2 && < 0.4, + process >= 1.1 && < 1.3, + filepath >= 1.3 && < 1.4, + directory >= 1.1 && < 1.3, + containers >= 0.4.1 && < 1, + random >= 1.0.1 && < 2, + bytestring >= 0.9.2 && < 1, + mtl >= 2.1 && < 2.2, + async >= 2.0 && < 2.1, + aeson >= 0.6.2 && < 0.9, + executable-path >= 0.0 && < 0.1, + unix >= 2.5 && < 2.8, + temporary >= 1.1.2.4 && < 1.3, + bytestring-trie >= 0.2 && < 0.3, + unordered-containers >= 0.2.3 && < 0.3, + text >= 0.11 && < 1.3, + fingertree >= 0.0.1 && < 0.2, + binary >= 0.7.1.0 && < 0.8, + data-accessor >= 0.2 && < 0.3, + data-accessor-mtl >= 0.2 && < 0.3, + crypto-api >= 0.12 && < 0.14, + pureMD5 >= 2.1 && < 2.2, + tagged >= 0.4 && < 0.8, + transformers >= 0.3 && < 0.4, + time >= 1.4 && < 1.5, + attoparsec >= 0.10 && < 0.13, + utf8-string >= 0.3 && < 0.4, + template-haskell, + -- our own private fork: + Cabal-ide-backend >= 1.23, + ghc-prim, + pretty-show + + default-language: Haskell2010 + default-extensions: MonoLocalBinds + BangPatterns + RecordWildCards + NamedFieldPuns + RankNTypes + MultiParamTypeClasses + ExistentialQuantification + FlexibleContexts + DeriveDataTypeable + other-extensions: CPP + TemplateHaskell + ScopedTypeVariables, + GeneralizedNewtypeDeriving + ghc-options: -Wall -fno-warn-unused-do-bind + +executable ide-backend-exe-cabal + hs-source-dirs: . + main-is: ide-backend-exe-cabal.hs + build-depends: ide-backend, + base ==4.*, + filemanip >= 0.3.6.2 && < 0.4, + process >= 1.1 && < 1.3, + filepath >= 1.3 && < 1.4, + directory >= 1.1 && < 1.3, + containers >= 0.4.1 && < 1, + random >= 1.0.1 && < 2, + bytestring >= 0.9.2 && < 1, + mtl >= 2.1 && < 2.2, + async >= 2.0 && < 2.1, + aeson >= 0.6.2 && < 0.9, + executable-path >= 0.0 && < 0.1, + unix >= 2.5 && < 2.8, + temporary >= 1.1.2.4 && < 1.3, + bytestring-trie >= 0.2 && < 0.3, + unordered-containers >= 0.2.3 && < 0.3, + text >= 0.11 && < 1.3, + fingertree >= 0.0.1 && < 0.2, + binary >= 0.7.1.0 && < 0.8, + data-accessor >= 0.2 && < 0.3, + data-accessor-mtl >= 0.2 && < 0.3, + crypto-api >= 0.12 && < 0.14, + pureMD5 >= 2.1 && < 2.2, + tagged >= 0.4 && < 0.8, + transformers >= 0.3 && < 0.4, + time >= 1.4 && < 1.5, + attoparsec >= 0.10 && < 0.13, + template-haskell, + -- our own private fork: + Cabal-ide-backend >= 1.22, + ghc-prim, + pretty-show + + default-language: Haskell2010 + default-extensions: MonoLocalBinds, + BangPatterns, RecordWildCards, NamedFieldPuns + other-extensions: CPP, TemplateHaskell, ScopedTypeVariables, + DeriveDataTypeable + ghc-options: -Wall -fno-warn-unused-do-bind + +test-suite typecheck-dir + type: exitcode-stdio-1.0 + main-is: typecheck-dir.hs + hs-source-dirs: test + build-depends: base, ide-backend, temporary, filemanip, directory, time, text + + default-language: Haskell2010 + default-extensions: MonoLocalBinds, + BangPatterns, RecordWildCards, NamedFieldPuns + other-extensions: CPP, TemplateHaskell, ScopedTypeVariables, + DeriveDataTypeable + ghc-options: -Wall -fno-warn-unused-do-bind + ghc-options: -with-rtsopts=-K16M + +test-suite TestSuite + type: exitcode-stdio-1.0 + main-is: TestSuite.hs + hs-source-dirs: TestSuite + -- TODO: This is only necessary for TestTools, which in + -- turn is used by the RPC test suite too. We should + -- probably merge that in, too. + test + other-modules: TestSuite.State + TestSuite.Assertions + TestSuite.Session + TestSuite.Tests.API + TestSuite.Tests.Autocompletion + TestSuite.Tests.BufferMode + TestSuite.Tests.BuildDoc + TestSuite.Tests.BuildExe + TestSuite.Tests.BuildLicenses + TestSuite.Tests.C + TestSuite.Tests.CabalMacros + TestSuite.Tests.Compilation + TestSuite.Tests.Compliance + TestSuite.Tests.Concurrency + TestSuite.Tests.Crash + TestSuite.Tests.Debugger + TestSuite.Tests.FFI + TestSuite.Tests.Integration + TestSuite.Tests.InterruptRunExe + TestSuite.Tests.InterruptRunStmt + TestSuite.Tests.Issues + TestSuite.Tests.Packages + TestSuite.Tests.Performance + TestSuite.Tests.SessionRestart + TestSuite.Tests.SessionState + TestSuite.Tests.SnippetEnvironment + TestSuite.Tests.StdIO + TestSuite.Tests.TH + TestSuite.Tests.TypeInformation + TestSuite.Tests.UpdateTargets + TestTools + build-depends: base, + ide-backend, + tasty, + HUnit, + tagged, + utf8-string, + text, + bytestring, + regex-compat, + filepath, + filemanip, + process, + directory, + stm, + unix, + random, + Cabal-ide-backend, + containers, + deepseq + default-language: Haskell2010 + ghc-options: -Wall + -threaded + -with-rtsopts=-N + default-extensions: RecordWildCards + NamedFieldPuns + DeriveDataTypeable + OverloadedStrings + ScopedTypeVariables + other-extensions: TypeSynonymInstances + FlexibleInstances + OverlappingInstances + +test-suite rpc-server + type: exitcode-stdio-1.0 + main-is: rpc-server.hs + hs-source-dirs: . server test + build-depends: base ==4.*, + directory ==1.*, + filemanip >= 0.3.6.2 && < 0.4, + process ==1.*, + filepath ==1.*, + containers >= 0.4.1 && < 1, + random >= 1.0.1 && < 2, + bytestring >= 0.9.2 && < 1, + async >= 2.0 && < 2.1, + aeson >= 0.6 && < 0.9, + temporary >= 1.1.2.4 && < 1.3, + test-framework >= 0.6 && < 0.9, + test-framework-hunit >= 0.2 && < 0.4, + HUnit >= 1.2 && < 1.3, + executable-path >= 0.0 && < 0.1, + unix >= 2.5 && < 2.8, + binary >= 0.7.1.0 && < 0.8, + template-haskell + + default-language: Haskell2010 + default-extensions: MonoLocalBinds, + BangPatterns, RecordWildCards, NamedFieldPuns + other-extensions: CPP, TemplateHaskell, ScopedTypeVariables, + DeriveDataTypeable + ghc-options: -Wall -fno-warn-unused-do-bind + other-modules: IdeSession.RPC.Server diff --git a/test/TestTools.hs b/test/TestTools.hs new file mode 100644 --- /dev/null +++ b/test/TestTools.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module TestTools where + +import qualified Control.Exception as Ex +import Data.Typeable (typeOf) +import System.Posix.Signals (Signal, raiseSignal) +import Test.HUnit (Assertion, assertBool, assertFailure) + +-- | Check that the given IO action raises the specified exception +assertRaises :: (Ex.Exception e, Show e) + => String -- ^ Message displayed if assertion fails + -> (e -> Bool) -- ^ Expected exception + -> IO a -- ^ Action to run + -> Assertion +assertRaises msg checkEx p = do + mex <- Ex.try p + case mex of + Right _ -> assertFailure (msg ++ ": No exception was raised") + Left ex -> + case Ex.fromException ex of + Just ex' -> assertBool (msg ++ ": Got the wrong exception: " ++ show ex') (checkEx ex') + Nothing -> assertFailure $ msg ++ ": " + ++ "Raised exception of the wrong type " + ++ exceptionType ex ++ ": " + ++ show ex + +-- | Find the type of an exception (only a few kinds of exceptions are supported) +exceptionType :: Ex.SomeException -> String +exceptionType (Ex.SomeException ex) = show (typeOf ex) + +-- | Like 'raiseSignal', but with a more general type +throwSignal :: Signal -> IO a +throwSignal signal = raiseSignal signal >> undefined diff --git a/test/rpc-server.hs b/test/rpc-server.hs new file mode 100644 --- /dev/null +++ b/test/rpc-server.hs @@ -0,0 +1,638 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable #-} +-- | Test suite for the RPC infrastructure +module Main where + +import Control.Applicative ((<$>), (<*>)) +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar +import Control.Monad (forM_, forever, replicateM, replicateM_) +import Data.Binary (Binary) +import Data.Function (on) +import Data.List (isInfixOf) +import Data.Typeable (Typeable) +import System.Environment (getArgs) +import System.Environment.Executable (getExecutablePath) +import System.FilePath (()) +import System.IO (hClose) +import System.IO.Temp (withTempDirectory, openTempFile) +import System.Posix.Files (createNamedPipe) +import System.Posix.Signals (sigKILL) +import qualified Control.Concurrent.Async as Async +import qualified Control.Exception as Ex +import qualified Data.Binary as Binary +import qualified System.Directory as Dir + +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assertEqual) + +import IdeSession.RPC.Client +import IdeSession.RPC.Server +import TestTools + +-------------------------------------------------------------------------------- +-- RPC-specific auxiliary -- +-------------------------------------------------------------------------------- + +-- | Call the current executable and pass the right arguments +forkTestServer :: String -> IO RpcServer +forkTestServer test = do + prog <- getExecutablePath + forkRpcServer prog ["--server", test] Nothing Nothing + +-- | Do an RPC call and verify the result +assertRpcEqual :: (Typeable req, Typeable resp, Binary req, Binary resp, Show req, Show resp, Eq resp) + => RpcServer -- ^ RPC server + -> req -- ^ Request + -> resp -- ^ Expected response + -> Assertion +assertRpcEqual server req resp = + assertRpcEquals server req [resp] + +-- | Like 'assertRpcEqual' but verify a number of responses, before throwing +-- the specified exception (if any) +assertRpcEquals :: (Typeable req, Typeable resp, Binary req, Binary resp, Show req, Show resp, Eq resp) + => RpcServer -- ^ RPC server + -> req -- ^ Request + -> [resp] -- ^ Expected responses + -> Assertion +assertRpcEquals server req resps = + assertRpc server (Put req $ foldr Get Done resps) + +data Conversation = + forall req. (Show req, Typeable req, Binary req) => Put req Conversation + | forall resp. (Show resp, Typeable resp, Binary resp, Eq resp) => Get resp Conversation + | Done + +assertRpc :: RpcServer -> Conversation -> Assertion +assertRpc server conversation = do + rpcConversation server $ \RpcConversation{..} -> + let checkConversation Done = + return () + checkConversation (Put req conv) = do + put req + checkConversation conv + checkConversation (Get resp conv) = do + assertEqual "" resp =<< get + checkConversation conv + in checkConversation conversation + +isServerKilledException :: ExternalException -> Bool +isServerKilledException = + ((==) `on` externalStdErr) (serverKilledException undefined) + +isServerIOException :: String -> ExternalException -> Bool +isServerIOException ex ExternalException{externalStdErr} = + ex `isInfixOf` externalStdErr + +-------------------------------------------------------------------------------- +-- Feature tests -- +-------------------------------------------------------------------------------- + +-- | Simple echo server +testEcho :: RpcServer -> Assertion +testEcho server = assertRpcEqual server "ping" "ping" + +testEchoServer :: FilePath -> RpcConversation -> IO () +testEchoServer _errorLog RpcConversation{..} = forever $ do + req <- get :: IO String + put req + +-- | Test stateful server +testState :: RpcServer -> Assertion +testState server = forM_ ([0 .. 9] :: [Int]) $ assertRpcEqual server () + +testStateServer :: MVar Int -> FilePath -> RpcConversation -> IO () +testStateServer st _errorLog RpcConversation{..} = forever $ do + () <- get + modifyMVar_ st $ \i -> do + put i + return (i + 1) + +-- | Test with request and response custom data types +data CountRequest = Increment | GetCount + deriving (Show, Typeable) +data CountResponse = DoneCounting | Count Int + deriving (Eq, Show, Typeable) + +instance Binary CountRequest where + put Increment = Binary.putWord8 0 + put GetCount = Binary.putWord8 1 + + get = do + header <- Binary.getWord8 + case header of + 0 -> return Increment + 1 -> return GetCount + _ -> fail "CountRequest.get: invalid header" + +instance Binary CountResponse where + put DoneCounting = Binary.putWord8 0 + put (Count i) = Binary.putWord8 1 >> Binary.put i + + get = do + header <- Binary.getWord8 + case header of + 0 -> return DoneCounting + 1 -> Count <$> Binary.get + _ -> fail "CountResponse.get: invalid header" + +testCustom :: RpcServer -> Assertion +testCustom server = do + assertRpcEqual server GetCount (Count 0) + assertRpcEqual server Increment DoneCounting + assertRpcEqual server GetCount (Count 1) + +testCustomServer :: MVar Int -> FilePath -> RpcConversation -> IO () +testCustomServer st _errorLog RpcConversation{..} = forever $ do + req <- get + case req of + Increment -> modifyMVar_ st $ \i -> do + put DoneCounting + return (i + 1) + GetCount -> modifyMVar_ st $ \i -> do + put (Count i) + return i + +-- | Test progress messages +testProgress :: RpcServer -> Assertion +testProgress server = + forM_ ([0 .. 9] :: [Int]) $ \i -> assertRpcEquals server i [i, i - 1 .. 0] + +testProgressServer :: FilePath -> RpcConversation -> IO () +testProgressServer _errorLog RpcConversation{..} = forever $ do + req <- get :: IO Int + forM_ [req, req - 1 .. 1] $ put + put (0 :: Int) + +-- | Test shutdown +testShutdown :: RpcServer -> Assertion +testShutdown server = do + assertRpcEqual server "ping" "ping" + shutdown server + assertRaises "" (== (userError "Manual shutdown")) + (rpc server "ping" :: IO String) + +-- | Test that stdout is available as usual on the server +testStdout :: RpcServer -> Assertion +testStdout server = do + assertRpcEqual server "ping" "ping" + shutdown server + assertRaises "" (== (userError "Manual shutdown")) + (rpc server "ping" :: IO String) + +testStdoutServer :: FilePath -> RpcConversation -> IO () +testStdoutServer _errorLog RpcConversation{..} = forever $ do + req <- get :: IO String + putStrLn " vvvv testStdout intentionally printing to stdout" + put req + +-- | Test that we can do concurrent get and put +testConcurrentGetPut :: RpcServer -> Assertion +testConcurrentGetPut server = + rpcConversation server $ \RpcConversation{..} -> do + forkIO $ threadDelay 1000000 >> put (1 :: Int) + Right 1 <- Ex.try get :: IO (Either Ex.SomeException Int) + return () + +testConcurrentGetPutServer :: FilePath -> RpcConversation -> IO () +testConcurrentGetPutServer _errorLog RpcConversation{..} = forever $ do + i <- get + put (i :: Int) + +-------------------------------------------------------------------------------- +-- Test generalized conversations -- +-------------------------------------------------------------------------------- + +data StartGame = StartGame Int Int | NoMoreGames + deriving (Show, Typeable) +data Guess = Guess Int | GiveUp | Yay + deriving (Show, Typeable, Eq) +data GuessReply = GuessCorrect | GuessIncorrect + deriving (Show, Typeable) + +instance Binary StartGame where + put (StartGame i j) = do Binary.putWord8 0 + Binary.put i + Binary.put j + put NoMoreGames = Binary.putWord8 1 + + get = do + header <- Binary.getWord8 + case header of + 0 -> StartGame <$> Binary.get <*> Binary.get + 1 -> return NoMoreGames + _ -> fail "Binary.get: Invalid header" + +instance Binary Guess where + put (Guess i) = Binary.putWord8 0 >> Binary.put i + put GiveUp = Binary.putWord8 1 + put Yay = Binary.putWord8 2 + + get = do + header <- Binary.getWord8 + case header of + 0 -> Guess <$> Binary.get + 1 -> return GiveUp + 2 -> return Yay + _ -> fail "Guess.get: invalid header" + +instance Binary GuessReply where + put GuessCorrect = Binary.putWord8 0 + put GuessIncorrect = Binary.putWord8 1 + + get = do + header <- Binary.getWord8 + case header of + 0 -> return GuessCorrect + 1 -> return GuessIncorrect + _ -> fail "GuessReply.get: invalid header" + +testConversation :: RpcServer -> Assertion +testConversation server = do + assertRpc server + $ Put (StartGame 1 10) + $ Get (Guess 1) + $ Put GuessIncorrect + $ Get (Guess 2) + $ Put GuessIncorrect + $ Get (Guess 3) + $ Put GuessCorrect + $ Get Yay + $ Done + assertRpc server + $ Put (StartGame 1 2) + $ Get (Guess 1) + $ Put GuessIncorrect + $ Get (Guess 2) + $ Put GuessIncorrect + $ Get GiveUp + $ Done + {- DISABLED. Whether or not we get this exception, or just sit here and wait, + depends on circumstances. Perhaps it would be nicer if we did tag messages + with some type information so that can catch these errors properly. + assertRaises "" typeError $ + assertRpcEqual server GuessCorrect GiveUp + where + typeError :: ExternalException -> Bool + typeError ExternalException{externalStdErr} = + "not enough bytes" `isInfixOf` externalStdErr + -} + assertRpcEqual server NoMoreGames () + +testConversationServer :: FilePath -> RpcConversation -> IO () +testConversationServer _errorLog RpcConversation{..} = outerLoop + where + outerLoop = do + req <- labelExceptions "testConversationServer outerLoop: " $ get + case req of + StartGame n m -> innerLoop n m >> outerLoop + NoMoreGames -> put () >> return () + + innerLoop n m + | n > m = put GiveUp + | otherwise = do put (Guess n) + answer <- labelExceptions "testConcurrentServer innerLoop: " $ get + case answer of + GuessCorrect -> put Yay + GuessIncorrect -> innerLoop (n + 1) m + +-------------------------------------------------------------------------------- +-- Error handling tests -- +-------------------------------------------------------------------------------- + +-- | Test crashing server +testCrash :: RpcServer -> Assertion +testCrash server = + assertRaises "" (isServerIOException crash) $ + assertRpcEqual server () () + +testCrashServer :: FilePath -> RpcConversation -> IO () +testCrashServer _errorLog RpcConversation{..} = do + () <- get + Ex.throwIO (userError crash) + +crash :: String +crash = "Intentional crash" + +-- | Test server which gets killed during a request +testKill :: RpcServer -> Assertion +testKill server = do + assertRpcEqual server "ping" "ping" -- First request goes through + assertRaises "" isServerKilledException $ + assertRpcEqual server "ping" "ping" -- Second does not + +testKillServer :: MVar Bool -> FilePath -> RpcConversation -> IO () +testKillServer firstRequest _errorLog RpcConversation{..} = forever $ do + req <- get :: IO String + modifyMVar_ firstRequest $ \isFirst -> do + if isFirst + then put req + else throwSignal sigKILL + return False + +-- | Test server which gets killed between requests +testKillAsync :: RpcServer -> Assertion +testKillAsync server = do + assertRpcEqual server "ping" "ping" + threadDelay 500000 -- Wait for server to exit + assertRaises "" isServerKilledException $ + assertRpcEqual server "ping" "ping" + +testKillAsyncServer :: FilePath -> RpcConversation -> IO () +testKillAsyncServer _errorLog RpcConversation{..} = forever $ do + req <- get :: IO String + -- Fork a thread which causes the server to crash 0.5 seconds after the request + forkIO $ threadDelay 250000 >> throwSignal sigKILL + put req + +-- | Test crash during decoding +data TypeWithFaultyDecoder = TypeWithFaultyDecoder + deriving (Show, Typeable) + +instance Binary TypeWithFaultyDecoder where + put _ = Binary.putWord8 0 -- >> return () + get = fail "Faulty decoder" + +testFaultyDecoder :: RpcServer -> Assertion +testFaultyDecoder server = + assertRaises "" (isServerIOException "Faulty decoder") $ + assertRpcEqual server TypeWithFaultyDecoder () + +testFaultyDecoderServer :: FilePath -> RpcConversation -> IO () +testFaultyDecoderServer _errorLog RpcConversation{..} = forever $ do + TypeWithFaultyDecoder <- get + put () + +-- | Test crash during encoding +data TypeWithFaultyEncoder = TypeWithFaultyEncoder + deriving (Show, Eq, Typeable) + +instance Binary TypeWithFaultyEncoder where + put _ = fail "Faulty encoder" + get = Binary.getWord8 >> return TypeWithFaultyEncoder + +testFaultyEncoder :: RpcServer -> Assertion +testFaultyEncoder server = + assertRaises "" ((== "Faulty encoder") . externalStdErr) $ + assertRpcEqual server () TypeWithFaultyEncoder + +testFaultyEncoderServer :: FilePath -> RpcConversation -> IO () +testFaultyEncoderServer _errorLog RpcConversation{..} = forever $ do + () <- get + put TypeWithFaultyEncoder + +-------------------------------------------------------------------------------- +-- Test errors during RPC calls with multiple responses -- +-------------------------------------------------------------------------------- + +-- | Test server which crashes after sending some intermediate responses +testCrashMulti :: RpcServer -> Assertion +testCrashMulti server = + assertRaises "" (isServerIOException crash) $ + assertRpcEquals server (3 :: Int) ([3, 2, 1, 0] :: [Int]) + +testCrashMultiServer :: FilePath -> RpcConversation -> IO () +testCrashMultiServer _errorLog RpcConversation{..} = forever $ do + req <- get :: IO Int + forM_ [req, req - 1 .. 1] $ put + Ex.throwIO (userError crash) + +-- | Like 'CrashMulti', but killed rather than an exception +testKillMulti :: RpcServer -> Assertion +testKillMulti server = + assertRaises "" isServerKilledException $ + assertRpcEquals server (3 :: Int) ([3, 2, 1, 0] :: [Int]) + +testKillMultiServer :: FilePath -> RpcConversation -> IO () +testKillMultiServer _errorLog RpcConversation{..} = forever $ do + req <- get :: IO Int + forM_ [req, req - 1 .. 1] $ put + throwSignal sigKILL + +-- | Like 'KillMulti', but now the server gets killed *between* messages +testKillAsyncMulti :: RpcServer -> Assertion +testKillAsyncMulti server = + assertRaises "" isServerKilledException $ + assertRpcEquals server (3 :: Int) ([3, 2, 1, 0] :: [Int]) + +testKillAsyncMultiServer :: FilePath -> RpcConversation -> IO () +testKillAsyncMultiServer _errorLog RpcConversation{..} = forever $ do + req <- get + forkIO $ threadDelay (250000 + (req - 1) * 50000) >> throwSignal sigKILL + forM_ [req, req - 1 .. 1] $ \i -> threadDelay 50000 >> put i + +-------------------------------------------------------------------------------- +-- Tests for errors in client code -- +-------------------------------------------------------------------------------- + +-- | Test letting the Progress object escape from the scope +testIllscoped :: RpcServer -> Assertion +testIllscoped server = do + conversation <- rpcConversation server $ return + assertRaises "" (== illscopedConversationException) (get conversation :: IO String) + assertRaises "" (== illscopedConversationException) (put conversation "hi") + +-- | Test what happens if the client specifies the wrong request type +-- +-- (The actual type is the type of the echo server: RpcServer String String) +testInvalidReqType :: RpcServer -> Assertion +testInvalidReqType server = + assertRaises "" (isServerIOException parseEx) $ + assertRpcEqual server () "ping" + where + parseEx = "not enough bytes" + +{- DISABLED: We cannot detect this reliably anymore, since we don't + encode type information anymore since the move to Binary +-- | Test what happens if the client specifies the wrong response type +-- +-- Note that since the decoding error now happens *locally*, the exception +-- is a regular userError, rather than an ExternalException +-- +-- (The actual type is the type of the echo server: RpcServer String String) +testInvalidRespType :: RpcServer -> Assertion +testInvalidRespType server = + assertRaises "" (== userError parseEx) $ + assertRpcEqual server "ping" () + where + -- TODO: do we want to insist on this particular parse error? + parseEx = "when expecting a (), encountered String instead" +-} + +-------------------------------------------------------------------------------- +-- Concurrent conversations -- +-- -- +-- It is important that all servers involved with the concurrent conversations-- +-- have a proper shutdown sequence or else we will get runtime exceptions when-- +-- we close the pipes. -- +-------------------------------------------------------------------------------- + +data ConcurrentServerRequest = + ConcurrentServerSanityCheck String + | ConcurrentServerSpawn + | ConcurrentServerTerminate + deriving (Typeable, Show) + +instance Binary ConcurrentServerRequest where + put (ConcurrentServerSanityCheck s) = Binary.putWord8 0 >> Binary.put s + put ConcurrentServerSpawn = Binary.putWord8 1 + put ConcurrentServerTerminate = Binary.putWord8 2 + + get = do + header <- Binary.getWord8 + case header of + 0 -> ConcurrentServerSanityCheck <$> Binary.get + 1 -> return ConcurrentServerSpawn + 2 -> return ConcurrentServerTerminate + _ -> fail "ConcurrentServerRequest.get: invalid header" + +testConcurrentServer :: FilePath -> RpcConversation -> IO () +testConcurrentServer _errorLog RpcConversation{..} = go + where + go = do + req <- labelExceptions "testConcurrentServer: " $ get + case req of + ConcurrentServerSanityCheck str -> do + put str + go + ConcurrentServerSpawn -> do + pipes <- newEmptyMVar :: IO (MVar (String, String, String)) + forkIO $ do + withTempDirectory "." "rpc" $ \tempDir -> do + let stdin = tempDir "stdin" + stdout = tempDir "stdout" + stderr = tempDir "stderr" + + createNamedPipe stdin 0o600 + createNamedPipe stdout 0o600 + + tmpDir <- Dir.getTemporaryDirectory + (errorLogPath, errorLogHandle) <- openTempFile tmpDir "rpc.log" + hClose errorLogHandle + + -- Once we have created the pipes we can tell the client + putMVar pipes (stdin, stdout, errorLogPath) + concurrentConversation stdin stdout stderr testConversationServer + + (stdin, stdout, errorLogPath) <- readMVar pipes + put (stdin, stdout, errorLogPath) + go + ConcurrentServerTerminate -> do + put () + return () + +testConcurrent :: RpcServer -> Assertion +testConcurrent server = do + -- test sequentially: echo, spawn conversation, run that conversation, repeat + replicateM_ 3 $ do + -- test we can echo + assertRpcEqual server (ConcurrentServerSanityCheck "ping") "ping" + + (stdin, stdout, stderr) <- rpc server ConcurrentServerSpawn + connectToRpcServer stdin stdout stderr $ testConversation + + -- test concurrent execution: spawn a bunch of servers, have conversations + -- with all of them concurrently, while still communicating on the original + -- conversation, too (note that the calls to 'rpc' to start the concurrent + -- conversations will be sequentialized) + clientConvs <- replicateM 10 $ Async.async $ do + (stdin, stdout, stderr) <- rpc server ConcurrentServerSpawn + connectToRpcServer stdin stdout stderr $ testConversation + + -- Echo on the original conversation while we have the other conversations + replicateM_ 100 $ + assertRpcEqual server (ConcurrentServerSanityCheck "ping") "ping" + + -- Wait for all client conversations to finish + forM_ clientConvs Async.wait + + -- Shutdown the main server + assertRpcEqual server ConcurrentServerTerminate () + +-------------------------------------------------------------------------------- +-- Driver -- +-------------------------------------------------------------------------------- + +tests :: [Test] +tests = [ + testGroup "Features" [ + testRPC "echo" testEcho + , testRPC "state" testState + , testRPC "custom" testCustom + , testRPC "progress" testProgress + , testRPC "shutdown" testShutdown + , testRPC "stdout" testStdout + , testRPC "conversation" testConversation + , testRPC "concurrentGetPut" testConcurrentGetPut + ] + , testGroup "Error handling" [ + testRPC "crash" testCrash + , testRPC "kill" testKill + , testRPC "killAsync" testKillAsync + , testRPC "faultyDecoder" testFaultyDecoder + , testRPC "faultyEncoder" testFaultyEncoder + ] + , testGroup "Error handling during RPC calls with multiple responses" [ + testRPC "crashMulti" testCrashMulti + , testRPC "killMulti" testKillMulti + , testRPC "killAsyncMulti" testKillAsyncMulti + ] + , testGroup "Client code errors" [ + testRPC "illscoped" testIllscoped + , testRPC "invalidReqType" testInvalidReqType +-- , testRPC "invalidRespType" testInvalidRespType + ] + , testGroup "Concurrent conversations" [ + testRPC "concurrent" testConcurrent + ] + ] + where + testRPC :: String -> (RpcServer -> Assertion) -> Test + testRPC name testWith = testCase name $ do + server <- forkTestServer name + testWith server + shutdown server + +main :: IO () +main = do + args <- getArgs + case args of + "--server" : test : args' -> case test of + "echo" -> rpcServer testEchoServer args' + "state" -> do st <- newMVar 0 + rpcServer (testStateServer st) args' + "custom" -> do st <- newMVar 0 + rpcServer (testCustomServer st) args' + "progress" -> rpcServer testProgressServer args' + "shutdown" -> rpcServer testEchoServer args' + "stdout" -> rpcServer testStdoutServer args' + "conversation" -> rpcServer testConversationServer args' + "concurrentGetPut" -> rpcServer testConcurrentGetPutServer args' + "crash" -> rpcServer testCrashServer args' + "kill" -> do firstRequest <- newMVar True + rpcServer (testKillServer firstRequest) args' + "killAsync" -> rpcServer testKillAsyncServer args' + "faultyDecoder" -> rpcServer testFaultyDecoderServer args' + "faultyEncoder" -> rpcServer testFaultyEncoderServer args' + "illscoped" -> rpcServer testEchoServer args' + "underconsumption" -> rpcServer testEchoServer args' + "overconsumption" -> rpcServer testEchoServer args' + "crashMulti" -> rpcServer testCrashMultiServer args' + "killMulti" -> rpcServer testKillMultiServer args' + "killAsyncMulti" -> rpcServer testKillAsyncMultiServer args' + "invalidReqType" -> rpcServer testEchoServer args' + "invalidRespType" -> rpcServer testEchoServer args' + "concurrent" -> rpcServer testConcurrentServer args' + _ -> error $ "Invalid server " ++ show test + _ -> defaultMain tests + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +labelExceptions :: String -> IO a -> IO a +labelExceptions label = Ex.handle aux + where + aux :: Ex.SomeException -> IO a + aux e = Ex.throwIO (userError (label ++ show e)) diff --git a/test/typecheck-dir.hs b/test/typecheck-dir.hs new file mode 100644 --- /dev/null +++ b/test/typecheck-dir.hs @@ -0,0 +1,94 @@ +module Main where + +import Control.Exception (bracket) +import Control.Monad (liftM, unless) +import Data.Monoid (mconcat) +import System.Directory +import System.Environment +import System.FilePath.Find (always, extension, find) +import System.IO.Temp (withTempDirectory) + +import IdeSession + +--- A sample program using the library. It type-checks all files +--- in the given directory and prints out the list of errors. + +-- | Some common extensions, etc. (please fill in). +-- Curiously "-XTypeFamilies" causes the type-checking of the default +-- test file to fail. The same file type-checks OK with the ghc-errors +-- test program (with no GHC extensions set). +defOpts :: [String] +defOpts = [ "-hide-all-packages" -- make sure we don't depend on local pkgs + , "-XCPP" + , "-XNoTemplateHaskell" -- TH not available when profiling + , "-XBangPatterns" + , "-XRecordWildCards" + , "-XNamedFieldPuns" + , "-XPatternGuards" + , "-XScopedTypeVariables" + , "-XMultiParamTypeClasses" + , "-XRankNTypes" +-- causes problems with the Cabal code: , "-XTypeFamilies" + , "-XForeignFunctionInterface" + , "-XDeriveDataTypeable" + , "-package template-haskell" + , "-package old-time" + , "-package parallel" + , "-package base" + , "-package deepseq" + , "-package filepath" + , "-package directory" + , "-package process" + , "-package time" + , "-package containers" + , "-package array" + , "-package pretty" + , "-package bytestring" + , "-package unix" + ] + +main :: IO () +main = do + args <- getArgs + let (originalSourcesDir, opts) = case args of + ["--help"] -> + error "usage: typecheck-dir [source-dir [ghc-options]]" + [dir] -> (dir, defOpts) + dir : optsArg -> (dir, optsArg) + [] -> ("TestSuite/inputs/Cabal-1.18.1.5", + defOpts) + slashTmp <- getTemporaryDirectory + withTempDirectory slashTmp "typecheck-dir." + $ check opts originalSourcesDir + +check :: [String] -> FilePath -> FilePath -> IO () +check opts what configDir = do + putStrLn $ "Copying files from: " ++ what ++ "\n" + ++ "to a temporary directory at: " ++ configDir ++ "\n" + -- Init session. + let sessionInitParams = defaultSessionInitParams { + sessionInitGhcOptions = opts + } + sessionConfig = defaultSessionConfig{ + configDir + -- , configInProcess = True + } + + bracket (initSession sessionInitParams sessionConfig) + shutdownSession $ \session -> do + isFile <- doesFileExist what + isDirectory <- doesDirectoryExist what + + unless (isFile || isDirectory) $ fail ("invalid argument " ++ what) + + modules <- if isFile + then return [what] + else find always ((`elem` sourceExtensions) `liftM` extension) what + + print modules + + let update = mconcat (map updateSourceFileFromFile modules) + + updateSession session update print + errs <- getSourceErrors session + putStrLn $ "\nErrors and warnings:\n" ++ unlines (map show errs)