packages feed

ide-backend (empty) → 0.9.0

raw patch · 74 files changed

+22031/−0 lines, 74 filesdep +Cabal-ide-backenddep +HUnitdep +aesonsetup-changed

Dependencies added: Cabal-ide-backend, HUnit, aeson, async, attoparsec, base, binary, bytestring, bytestring-trie, containers, crypto-api, data-accessor, data-accessor-mtl, deepseq, directory, executable-path, filemanip, filepath, fingertree, ghc-prim, ide-backend, mtl, pretty-show, process, pureMD5, random, regex-compat, stm, tagged, tasty, template-haskell, temporary, test-framework, test-framework-hunit, text, time, transformers, unix, unordered-containers, utf8-string

Files

+ CoreLicenses.txt view
@@ -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.++-----------------------------------------------------------------------------
+ IdeSession.hs view
@@ -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
+ IdeSession/Cabal.hs view
@@ -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"
+ IdeSession/Config.hs view
@@ -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+  }
+ IdeSession/ExeCabalClient.hs view
@@ -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
+ IdeSession/GHC/API.hs view
@@ -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"
+ IdeSession/GHC/Client.hs view
@@ -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
+ IdeSession/GHC/Requests.hs view
@@ -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"
+ IdeSession/GHC/Responses.hs view
@@ -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"
+ IdeSession/Licenses.hs view
@@ -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."+    , ""+    , "    <one line to give the program's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    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."+    , ""+    , "  <signature of Ty Coon>, 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. <http://fsf.org/>"+    , " 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."+    , ""+    , "    <one line to give the program's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    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 <http://www.gnu.org/licenses/>."+    , ""+    , "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:"+    , ""+    , "    <program>  Copyright (C) <year>  <name of author>"+    , "    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"+    , "<http://www.gnu.org/licenses/>."+    , ""+    , "  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"+    , "<http://www.gnu.org/philosophy/why-not-lgpl.html>."+    , ""+    ]++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."+    , ""+    , "    <one line to give the library's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    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."+    , ""+    , "  <signature of Ty Coon>, 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. <http://fsf.org/>"+    , " 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."+    ]
+ IdeSession/Query.hs view
@@ -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 "<<server died>>")+            , 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)
+ IdeSession/RPC/API.hs view
@@ -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
+ IdeSession/RPC/Client.hs view
@@ -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' <<your request handler>>+-- >     _ ->+-- >       <<deal with other cases>>+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))+
+ IdeSession/RPC/Server.hs view
@@ -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)
+ IdeSession/RPC/Stream.hs view
@@ -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)
+ IdeSession/State.hs view
@@ -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 }
+ IdeSession/Strict/Container.hs view
@@ -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
+ IdeSession/Strict/IORef.hs view
@@ -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
+ IdeSession/Strict/IntMap.hs view
@@ -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)
+ IdeSession/Strict/IntervalMap.hs view
@@ -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)
+ IdeSession/Strict/List.hs view
@@ -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
+ IdeSession/Strict/MVar.hs view
@@ -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)
+ IdeSession/Strict/Map.hs view
@@ -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)
+ IdeSession/Strict/Maybe.hs view
@@ -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
+ IdeSession/Strict/StateT.hs view
@@ -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
+ IdeSession/Strict/Trie.hs view
@@ -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
+ IdeSession/Types/Private.hs view
@@ -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{..}
+ IdeSession/Types/Progress.hs view
@@ -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
+ IdeSession/Types/Public.hs view
@@ -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+    _ -> "<local identifier>"+ 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))+-}
+ IdeSession/Types/Translation.hs view
@@ -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 "<<unknown id>>"+        , idSpace       = Public.VarName+        , idType        = Nothing+        , idDefinedIn   = unknownModule+        , idDefSpan     = Public.TextSpan (Text.pack "<<unknown span>>")+        , idHomeModule  = Nothing+        }++      unknownModule = Public.ModuleId {+          moduleName    = Text.pack "<<unknown module>>"+        , modulePackage = unknownPackage+        }++      unknownPackage = Public.PackageId {+         packageName    = Text.pack "<<unknown package>>"+       , packageVersion = Nothing+       , packageKey     = Text.pack "<<unknown package>>"+       }++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 "<<unknown filepath>>"++{------------------------------------------------------------------------------+  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+      }
+ IdeSession/Update.hs view
@@ -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 "<stdout> 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+  }
+ IdeSession/Update/ExecuteSessionUpdate.hs view
@@ -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 "<gcc error>")+      , 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
+ IdeSession/Update/IdeSessionUpdate.hs view
@@ -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{..}) = "<<FileInfo " ++ fileInfoRemoteFile ++ ">>"++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] }
+ IdeSession/Util.hs view
@@ -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
+ IdeSession/Util/BlockingOps.hs view
@@ -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
+ IdeSession/Util/PrettyVal.hs view
@@ -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
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ TestSuite/TestSuite.hs view
@@ -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
+ TestSuite/TestSuite/Assertions.hs view
@@ -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 ""
+ TestSuite/TestSuite/Session.hs view
@@ -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)
+ TestSuite/TestSuite/State.hs view
@@ -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
+ TestSuite/TestSuite/Tests/API.hs view
@@ -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
+ TestSuite/TestSuite/Tests/Autocompletion.hs view
@@ -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 <wired into compiler> (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"+      ])
+ TestSuite/TestSuite/Tests/BufferMode.hs view
@@ -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]
+ TestSuite/TestSuite/Tests/BuildDoc.hs view
@@ -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
+ TestSuite/TestSuite/Tests/BuildExe.hs view
@@ -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")]
+ TestSuite/TestSuite/Tests/BuildLicenses.hs view
@@ -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
+ TestSuite/TestSuite/Tests/C.hs view
@@ -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 "<gcc error>")) (errorSpan e1)+        -- The ByteCodeLink exception because of the missing symbol+        assertEqual "" (TextSpan (T.pack "<from GhcException>")) (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 <stdio.h>"+        , "#include <blankheader.h>"+        , "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 <stdio.h>"+        , "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 <stdio.h>"+        , "void defined_in_A() {"+        , "  printf(\"In A\\n\");"+        , "}"+        ]+    cfileB = L.unlines $+        [ "#include <stdio.h>"+        , ""+        , "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 <stdio.h>"+        , ""+        , "void also_defined_in_B();"+        , ""+        , "void defined_in_A() {"+        , "  printf(\"In A\\n\");"+        , "  also_defined_in_B();"+        , "}"+        ]+    cfileB = L.unlines $+        [ "#include <stdio.h>"+        , ""+        , "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)
+ TestSuite/TestSuite/Tests/CabalMacros.hs view
@@ -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
+ TestSuite/TestSuite/Tests/Compilation.hs view
@@ -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 <ideSourcesDir>/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 <ideSourcesDir>/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
+ TestSuite/TestSuite/Tests/Compliance.hs view
@@ -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
+ TestSuite/TestSuite/Tests/Concurrency.hs view
@@ -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)
+ TestSuite/TestSuite/Tests/Crash.hs view
@@ -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 "<<server died>>"+          , 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")]
+ TestSuite/TestSuite/Tests/Debugger.hs view
@@ -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')
+ TestSuite/TestSuite/Tests/FFI.hs view
@@ -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 = <<server died>>, 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 <smmintrin.h>\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 <smmintrin.h>\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)
+ TestSuite/TestSuite/Tests/Integration.hs view
@@ -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
+ TestSuite/TestSuite/Tests/InterruptRunExe.hs view
@@ -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: <<loop>>\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))
+ TestSuite/TestSuite/Tests/InterruptRunStmt.hs view
@@ -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))
+ TestSuite/TestSuite/Tests/Issues.hs view
@@ -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 <https://ghc.haskell.org/trac/ghc/ticket/10052>+    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 <zlib.h>"+               , "#include <stdio.h>"+               , "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 <stdio.h>"+               , "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)"+            ])
+ TestSuite/TestSuite/Tests/Packages.hs view
@@ -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 = "<command line>: 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 = "<command line>: 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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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 "<no location info>") (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 "<no location info>") (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"+            ])
+ TestSuite/TestSuite/Tests/Performance.hs view
@@ -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
+ TestSuite/TestSuite/Tests/SessionRestart.hs view
@@ -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)
+ TestSuite/TestSuite/Tests/SessionState.hs view
@@ -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 []" []
+ TestSuite/TestSuite/Tests/SnippetEnvironment.hs view
@@ -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"+            ])
+ TestSuite/TestSuite/Tests/StdIO.hs view
@@ -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
+ TestSuite/TestSuite/Tests/TH.hs view
@@ -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
+ TestSuite/TestSuite/Tests/TypeInformation.hs view
@@ -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" "<no location info>" "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" "<wired into compiler>" "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 "<no location info>") (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" "<wired into compiler>" "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" "<wired into compiler>" "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" "<wired into compiler>" "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" "<wired into compiler>" "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" "<wired into compiler>" "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" "<wired into compiler>" "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" "<no location info>" "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" "<no location info>" "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 "<no location info>") (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" "<no location info>" "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 "<no location info>") (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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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 "<no location info>") (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" "<no location info>" "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" "<wired into compiler>" "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 "<no location info>") (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" "<no location info>" "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" "<no location info>" "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" "<wired into compiler>" "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" "<wired into compiler>" "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" "<wired into compiler>" "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" "<wired into compiler>" "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" "<wired into compiler>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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" "<no location info>" "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"+             ])
+ TestSuite/TestSuite/Tests/UpdateTargets.hs view
@@ -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 <ideSourcesDir>/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 ()"+  ]
+ ide-backend-exe-cabal.hs view
@@ -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
+ ide-backend.cabal view
@@ -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 <duncan@well-typed.com>+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
+ test/TestTools.hs view
@@ -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
+ test/rpc-server.hs view
@@ -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))
+ test/typecheck-dir.hs view
@@ -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)