leksah-server 0.10.0.4 → 0.12.0.3
raw patch · 14 files changed
+1276/−707 lines, 14 filesdep +attoparsecdep +attoparsec-enumeratordep +enumeratordep −mtldep ~Cabaldep ~basedep ~deepseqPVP ok
version bump matches the API change (PVP)
Dependencies added: attoparsec, attoparsec-enumerator, enumerator, process, transformers
Dependencies removed: mtl
Dependency ranges changed: Cabal, base, deepseq, filepath, ghc, haddock, ltk, pretty, time, unix
API changes (from Hackage documentation)
- IDE.Core.CTypes: configDirName :: String
- IDE.Core.CTypes: instance NFData Version
- IDE.Core.CTypes: leksahVersion :: String
+ IDE.Core.CTypes: leksahVersion, configDirName :: String
+ IDE.Utils.FileUtils: isEmptyDirectory :: FilePath -> IO Bool
+ IDE.Utils.Tool: data ProcessHandle :: *
+ IDE.Utils.Tool: getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode)
+ IDE.Utils.Tool: interruptProcessGroupOf :: ProcessHandle -> IO ()
+ IDE.Utils.Tool: newGhci' :: [String] -> (Iteratee ToolOutput IO ()) -> IO ToolState
+ IDE.Utils.Tool: runCommand :: String -> IO ProcessHandle
+ IDE.Utils.Tool: runInteractiveProcess :: FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> IO (Handle, Handle, Handle, ProcessHandle)
+ IDE.Utils.Tool: runProcess :: FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> Maybe Handle -> Maybe Handle -> Maybe Handle -> IO ProcessHandle
+ IDE.Utils.Tool: waitForProcess :: ProcessHandle -> IO ExitCode
+ IDE.Utils.Utils: emptySessionFilename :: [Char]
+ IDE.Utils.Utils: leksahCandyFileExtension :: [Char]
+ IDE.Utils.Utils: leksahFlagFileExtension :: [Char]
+ IDE.Utils.Utils: leksahKeymapFileExtension :: [Char]
+ IDE.Utils.Utils: leksahMetadataDebugExtension :: [Char]
+ IDE.Utils.Utils: leksahMetadataPathFileExtension :: [Char]
+ IDE.Utils.Utils: leksahMetadataSystemFileExtension :: [Char]
+ IDE.Utils.Utils: leksahMetadataWorkspaceFileExtension :: [Char]
+ IDE.Utils.Utils: leksahPreferencesFileExtension :: [Char]
+ IDE.Utils.Utils: leksahSessionFileExtension :: [Char]
+ IDE.Utils.Utils: leksahSourcesFileExtension :: [Char]
+ IDE.Utils.Utils: leksahTemplateFileExtension :: [Char]
+ IDE.Utils.Utils: leksahWorkspaceFileExtension :: [Char]
+ IDE.Utils.Utils: packageSessionFilename :: [Char]
+ IDE.Utils.Utils: standardCandyFilename :: [Char]
+ IDE.Utils.Utils: standardKeymapFilename :: [Char]
+ IDE.Utils.Utils: standardModuleTemplateFilename :: [Char]
+ IDE.Utils.Utils: standardPreferencesFilename :: [Char]
+ IDE.Utils.Utils: standardSessionFilename :: [Char]
+ IDE.Utils.Utils: standardSourcesFilename :: [Char]
+ IDE.Utils.Utils: strippedPreferencesFilename :: [Char]
- IDE.Utils.Tool: ToolCommand :: String -> ([ToolOutput] -> IO ()) -> ToolCommand
+ IDE.Utils.Tool: ToolCommand :: String -> String -> (Iteratee ToolOutput IO ()) -> ToolCommand
- IDE.Utils.Tool: ToolPrompt :: ToolOutput
+ IDE.Utils.Tool: ToolPrompt :: String -> ToolOutput
- IDE.Utils.Tool: executeCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO ()
+ IDE.Utils.Tool: executeCommand :: ToolState -> String -> String -> Iteratee ToolOutput IO () -> IO ()
- IDE.Utils.Tool: executeGhciCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO ()
+ IDE.Utils.Tool: executeGhciCommand :: ToolState -> String -> Iteratee ToolOutput IO () -> IO ()
- IDE.Utils.Tool: newGhci :: [String] -> [String] -> ([ToolOutput] -> IO ()) -> IO ToolState
+ IDE.Utils.Tool: newGhci :: [String] -> [String] -> (Iteratee ToolOutput IO ()) -> IO ToolState
- IDE.Utils.Tool: runTool :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle)
+ IDE.Utils.Tool: runTool :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> IO (Enumerator ToolOutput m b, ProcessHandle)
Files
- data/prefscoll.lkshp +1/−1
- leksah-server.cabal +182/−142
- src/IDE/Core/CTypes.hs +14/−3
- src/IDE/HeaderParser.hs +35/−5
- src/IDE/Metainfo/Collector.hs +1/−1
- src/IDE/Metainfo/InterfaceCollector.hs +52/−6
- src/IDE/Metainfo/PackageCollector.hs +13/−1
- src/IDE/Metainfo/SourceCollectorH.hs +16/−15
- src/IDE/Metainfo/SourceDB.hs +6/−7
- src/IDE/Metainfo/WorkspaceCollector.hs +35/−7
- src/IDE/Utils/FileUtils.hs +13/−9
- src/IDE/Utils/GHCUtils.hs +38/−4
- src/IDE/Utils/Tool.hs +635/−506
- tests/TestTool.hs +235/−0
data/prefscoll.lkshp view
@@ -1,7 +1,7 @@ Paths under which haskell sources for packages may be found: [] Maybe a directory for unpacking cabal packages:- Just "~/.leksah-0.8/packageSources"+ Just "~/.leksah-0.12/packageSources" An URL to load prebuild metadata: "http://www.leksah.org" A strategy for downloading prebuild metadata:
leksah-server.cabal view
@@ -1,142 +1,182 @@-name: leksah-server-version: 0.10.0.4-cabal-version: >= 1.8-build-type: Simple-license: GPL-license-file: LICENSE-copyright: 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie-maintainer: maintainer@leksah.org-stability: provisional-homepage: http://leksah.org-package-url: http://code.haskell.org/leksah-collector-bug-reports: http://code.google.com/p/leksah/issues/list-synopsis: Metadata collection for leksah-description: The interface to GHC-API for leksah-category: IDE-author: Juergen "jutaro" Nicklisch-Franken, Hamish Mackenzie-data-dir: ""-tested-with: GHC ==6.10 || ==6.12 || ==7.0-data-files:- data/prefscoll.lkshp-flag curl- Default: False- Description: Use runs curl instead of wget (curl is the default on OSX)--flag libcurl- Default: False- Description: Use libcurl instead of running wget--flag threaded- default: True- description: Build with support for multithreaded execution--library- build-depends: Cabal >=1.6.0.1 && <1.11, base >= 4.0.0.0 && <4.4, binary >=0.5.0.0 && <0.6,- binary-shared >=0.8 && <0.9, bytestring >=0.9.0.1 && <0.10,- containers >=0.2.0.0 && <0.5,- directory >=1.0.0.2 && <1.2, filepath >=1.1.0.1 && <1.3, ghc >=6.10.1 && <7.1,- ltk >=0.9 && <1.0, mtl >=1.1.0.2 && <2.1, parsec >=2.1.0.1 && <3.2,- pretty >=1.0.1.0 && <1.1, process-leksah >=1.0.1.3 && <1.1, time >=1.1 && <1.3, deepseq >=1.1 && <1.2,- hslogger >= 1.0.7 && <1.2, network >=2.2 && <3.0- if (impl(ghc >= 6.12))- build-depends: haddock >= 2.7.2 && <2.10- else- build-depends: haddock-leksah == 2.5.0- if os(windows)- build-depends: Win32 >=2.2.0.0 && <2.3- extra-libraries: kernel32- else- build-depends: unix >=2.3.1.0 && <2.5-- if flag(curl) || os(osx)- cpp-options: -DUSE_CURL-- if flag(libcurl)- build-depends: curl >=1.3.5 && <1.4- cpp-options: -DUSE_LIBCURL-- exposed-modules: IDE.Utils.GHCUtils IDE.Utils.Utils IDE.Utils.Tool- IDE.Utils.FileUtils IDE.Core.CTypes IDE.Core.Serializable IDE.StrippedPrefs- IDE.Utils.Server IDE.Metainfo.PackageCollector IDE.Utils.VersionUtils- exposed: True- buildable: True- extensions: CPP- hs-source-dirs: src- other-modules:- IDE.Metainfo.WorkspaceCollector IDE.Metainfo.InterfaceCollector- IDE.Metainfo.SourceCollectorH- IDE.Metainfo.SourceDB Paths_leksah_server- if (impl(ghc >= 6.12))- ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans -O2- else- ghc-options: -Wall -ferror-spans -O2- ghc-prof-options: -auto-all -prof--executable leksah-server- build-depends: Cabal >=1.6.0.1 && <1.11, base >= 4.0.0.0 && <4.4, binary >=0.5.0.0 && <0.6,- binary-shared >=0.8 && <0.9, bytestring >=0.9.0.1 && <0.10,- containers >=0.2.0.0 && <0.5,- directory >=1.0.0.2 && <1.2, filepath >=1.1.0.1 && <1.3, ghc >=6.10.1 && <7.1,- ltk >=0.9 && <1.0, mtl >=1.1.0.2 && <2.1, parsec >=2.1.0.1 && <3.2,- pretty >=1.0.1.0 && <1.1, process-leksah >=1.0.1.3 && <1.1, time >=1.1 && <1.3, deepseq >=1.1 && <1.2,- hslogger >= 1.0.7 && <1.2, network >=2.2 && <3.0- if (impl(ghc >= 6.12))- build-depends: haddock >= 2.7.2 && <2.10- else- build-depends: haddock-leksah == 2.5.0-- if os(windows)- build-depends: Win32 >=2.2.0.0 && <2.3- extra-libraries: kernel32- else- build-depends: unix >=2.3.1.0 && <2.5-- if flag(curl) || os(osx)- cpp-options: -DUSE_CURL-- if flag(libcurl)- build-depends: curl >=1.3.5 && <1.4- cpp-options: -DUSE_LIBCURL-- main-is: IDE/Metainfo/Collector.hs- buildable: True- extensions: CPP- hs-source-dirs: src- other-modules: IDE.StrippedPrefs IDE.Utils.GHCUtils IDE.Utils.Utils- IDE.Core.CTypes IDE.Core.Serializable- IDE.Metainfo.WorkspaceCollector IDE.Metainfo.InterfaceCollector- IDE.Metainfo.SourceCollectorH IDE.Metainfo.SourceDB IDE.Utils.Tool- IDE.HeaderParser IDE.Metainfo.PackageCollector-- if flag(threaded)- ghc-options: -threaded-- if impl(ghc >= 7.0)- ghc-options: -rtsopts-- if impl(ghc >= 6.12)- ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans -O2- else- ghc-options: -Wall -ferror-spans -O2- ghc-prof-options: -auto-all -prof--executable leksahecho- main-is: LeksahEcho.hs- buildable: True- extensions: CPP- hs-source-dirs: src- ghc-prof-options: -auto-all -prof--- ghc-shared-options: -auto-all -prof- build-depends: base >= 4.0.0.0 && <4.4, hslogger >= 1.0.7 && <1.2, deepseq >=1.1 && <1.2,- process-leksah >=1.0.1.3 && <1.1--- if flag(threaded)- ghc-options: -threaded-- if (impl(ghc >= 6.12))- ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans -O2- else- ghc-options: -Wall -ferror-spans -O2--+name: leksah-server +version: 0.12.0.3 +cabal-version: >= 1.10.2 +build-type: Simple +license: GPL +license-file: LICENSE +copyright: 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie +maintainer: maintainer@leksah.org +stability: provisional +homepage: http://leksah.org +package-url: http://code.haskell.org/leksah-collector +bug-reports: http://code.google.com/p/leksah/issues/list +synopsis: Metadata collection for leksah +description: The interface to GHC-API for leksah +category: IDE +author: Juergen "jutaro" Nicklisch-Franken, Hamish Mackenzie +data-dir: "" +tested-with: GHC ==6.10 || ==6.12 || ==7.0 +data-files: + data/prefscoll.lkshp +flag curl + Default: False + Description: Use runs curl instead of wget (curl is the default on OSX) + +flag libcurl + Default: False + Description: Use libcurl instead of running wget + +flag threaded + default: True + description: Build with support for multithreaded execution + +library + default-language: Haskell98 + build-depends: Cabal >=1.6.0.1 && <1.15, base >= 4.0.0.0 && <4.6, binary >=0.5.0.0 && <0.6, + binary-shared >=0.8 && <0.9, bytestring >=0.9.0.1 && <0.10, + containers >=0.2.0.0 && <0.5, + directory >=1.0.0.2 && <1.2, filepath >=1.1.0.1 && <1.4, ghc >=6.10.1 && <7.5, + ltk >=0.12 && <0.13, parsec >=2.1.0.1 && <3.2, + pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.5, deepseq >=1.1 && <1.4, + hslogger >= 1.0.7 && <1.2, network >=2.2 && <3.0, enumerator >=0.4.14 && < 0.5, + attoparsec-enumerator >=0.3 && <0.4, attoparsec >=0.10.0.3 && <0.11, + transformers >=0.2.2.0 && <0.3 + if (impl(ghc >= 7.4)) + build-depends: haddock >= 2.7.2 && <2.11 + else + if (impl(ghc >= 7.2)) + build-depends: haddock >= 2.7.2 && <2.10 + else + if (impl(ghc >= 7.0)) + build-depends: haddock >= 2.7.2 && <2.9.3 + else + if (impl(ghc >= 6.12)) + build-depends: haddock >= 2.7.2 && <2.9 + else + build-depends: haddock-leksah == 2.5.0 + + if (impl(ghc >= 7.2)) + build-depends: process >= 1.1 && <1.2 + else + build-depends: process-leksah >=1.0.1.3 && <1.1 + + if os(windows) + build-depends: Win32 >=2.2.0.0 && <2.3 + extra-libraries: kernel32 + else + build-depends: unix >=2.3.1.0 && <2.6 + + if flag(curl) || os(osx) + cpp-options: -DUSE_CURL + + if flag(libcurl) + build-depends: curl >=1.3.5 && <1.4 + cpp-options: -DUSE_LIBCURL + + exposed-modules: IDE.Utils.GHCUtils IDE.Utils.Utils IDE.Utils.Tool + IDE.Utils.FileUtils IDE.Core.CTypes IDE.Core.Serializable IDE.StrippedPrefs + IDE.Utils.Server IDE.Metainfo.PackageCollector IDE.Utils.VersionUtils + exposed: True + buildable: True + default-extensions: CPP + hs-source-dirs: src + other-modules: + IDE.Metainfo.WorkspaceCollector IDE.Metainfo.InterfaceCollector + IDE.Metainfo.SourceCollectorH + IDE.Metainfo.SourceDB Paths_leksah_server + if (impl(ghc >= 6.12)) + ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans -O2 + else + ghc-options: -Wall -ferror-spans -O2 + ghc-prof-options: -auto-all -prof + +executable leksah-server + default-language: Haskell98 + build-depends: Cabal >=1.6.0.1 && <1.15, base >= 4.0.0.0 && <4.6, binary >=0.5.0.0 && <0.6, + binary-shared >=0.8 && <0.9, bytestring >=0.9.0.1 && <0.10, + containers >=0.2.0.0 && <0.5, + directory >=1.0.0.2 && <1.2, filepath >=1.1.0.1 && <1.6, ghc >=6.10.1 && <7.5, + ltk >=0.12 && <0.13, parsec >=2.1.0.1 && <3.2, + pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.5, deepseq >=1.1 && <1.4, + hslogger >= 1.0.7 && <1.2, network >=2.2 && <3.0, enumerator >= 0.4.14 && <0.5, + attoparsec-enumerator >=0.3 && <0.4, attoparsec >=0.10.0.3 && <0.11, + transformers >=0.2.2.0 && <0.3 + if (impl(ghc >= 7.4)) + build-depends: haddock >= 2.7.2 && <2.11 + else + if (impl(ghc >= 7.2)) + build-depends: haddock >= 2.7.2 && <2.10 + else + if (impl(ghc >= 7.0)) + build-depends: haddock >= 2.7.2 && <2.9.3 + else + if (impl(ghc >= 6.12)) + build-depends: haddock >= 2.7.2 && <2.9 + else + build-depends: haddock-leksah == 2.5.0 + + if (impl(ghc >= 7.2)) + build-depends: process >= 1.1 && <1.2 + else + build-depends: process-leksah >=1.0.1.3 && <1.1 + + if os(windows) + build-depends: Win32 >=2.2.0.0 && <2.3 + extra-libraries: kernel32 + else + build-depends: unix >=2.3.1.0 && <2.6 + + if flag(curl) || os(osx) + cpp-options: -DUSE_CURL + + if flag(libcurl) + build-depends: curl >=1.3.5 && <1.4 + cpp-options: -DUSE_LIBCURL + + main-is: IDE/Metainfo/Collector.hs + buildable: True + default-extensions: CPP + hs-source-dirs: src + other-modules: IDE.StrippedPrefs IDE.Utils.GHCUtils IDE.Utils.Utils + IDE.Core.CTypes IDE.Core.Serializable + IDE.Metainfo.WorkspaceCollector IDE.Metainfo.InterfaceCollector + IDE.Metainfo.SourceCollectorH IDE.Metainfo.SourceDB IDE.Utils.Tool + IDE.HeaderParser IDE.Metainfo.PackageCollector + + if flag(threaded) + ghc-options: -threaded + + if impl(ghc >= 7.0) + ghc-options: -rtsopts + + if impl(ghc >= 6.12) + ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans -O2 + else + ghc-options: -Wall -ferror-spans -O2 + ghc-prof-options: -auto-all -prof + +executable leksahecho + default-language: Haskell98 + main-is: LeksahEcho.hs + buildable: True + default-extensions: CPP + hs-source-dirs: src + ghc-prof-options: -auto-all -prof +-- ghc-shared-options: -auto-all -prof + build-depends: base >= 4.0.0.0 && <4.6, hslogger >= 1.0.7 && <1.2, deepseq >=1.1 && <1.4, + bytestring >=0.9.0.1 && <0.10, enumerator >= 0.4.14 && <0.5, + attoparsec-enumerator >=0.3 && <0.4, attoparsec >=0.10.0.3 && <0.11, + transformers >=0.2.2.0 && <0.3 + + if (impl(ghc >= 7.2)) + build-depends: process >= 1.1 && <1.2 + else + build-depends: process-leksah >=1.0.1.3 && <1.1 + + if flag(threaded) + ghc-options: -threaded + + if (impl(ghc >= 6.12)) + ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans -O2 + else + ghc-options: -Wall -ferror-spans -O2
src/IDE/Core/CTypes.hs view
@@ -72,9 +72,10 @@ (PackageName(..), PackageIdentifier(..)) import Distribution.ModuleName (components, ModuleName) import Data.ByteString.Char8 (ByteString)-import Distribution.Text (Text(..), simpleParse, display)+import Distribution.Text (simpleParse, display) import qualified Data.ByteString.Char8 as BS (unpack, empty)-import qualified Data.Map as Map (lookup,keysSet,splitLookup, insertWith,empty,elems,union)+import qualified Data.Map as Map (lookup,keysSet,splitLookup, insertWith,empty,elems,union,toList)+import qualified Data.Set as Set (toList) import Text.PrettyPrint as PP import Text.PrinterParser import Data.Char (isAlpha)@@ -89,7 +90,7 @@ -- leksahVersion, configDirName :: String-leksahVersion = "0.10"+leksahVersion = "0.12" configDirName = ".leksah-" ++ leksahVersion metadataVersion :: Integer@@ -475,6 +476,14 @@ -- --------------------------------------------------------------------- -- NFData instances for forcing evaluation --+#if MIN_VERSION_deepseq(1,2,0) && !MIN_VERSION_containers(0,4,2)+instance (NFData k, NFData a) => NFData (Map k a) where+ rnf = rnf . Map.toList++instance NFData a => NFData (Set a) where+ rnf = rnf . Set.toList+#endif+ instance NFData Location where rnf pd = rnf (locationSLine pd)@@ -535,7 +544,9 @@ instance NFData BS.ByteString where rnf b = seq b () +#if !MIN_VERSION_ghc(7,3,0) instance NFData Version where rnf v = seq v ()+#endif instance NFData PackModule where rnf pd = rnf (pack pd)
src/IDE/HeaderParser.hs view
@@ -23,10 +23,14 @@ import FastString(unpackFS) import RdrName(showRdrName) import IDE.Utils.GHCUtils-import Control.Monad.Trans (liftIO) import Data.Maybe (mapMaybe)+#if MIN_VERSION_ghc(7,4,1)+import Outputable(pprPrefixOcc,showSDoc)+#else import Outputable(pprHsVar,showSDoc)-import IDE.Utils.FileUtils (figureOutHaddockOpts, figureOutGhcOpts)+#endif+import IDE.Utils.FileUtils (figureOutHaddockOpts)+import Control.Monad.IO.Class (MonadIO(..)) parseTheHeader :: FilePath -> IO ServerAnswer parseTheHeader filePath = do@@ -37,12 +41,12 @@ Left str -> return (ServerFailed str) Right (pr@HsModule{ hsmodImports = []}) -> do let i = case hsmodDecls pr of- decls@(_hd:_tl) -> (foldl (\ a b -> min a (srcSpanStartLine (getLoc b))) 0 decls) - 1+ decls@(_hd:_tl) -> (foldl (\ a b -> min a (srcSpanStartLine' (getLoc b))) 0 decls) - 1 [] -> case hsmodExports pr of- Just list -> (foldl (\ a b -> max a (srcSpanEndLine (getLoc b))) 0 list) + 1+ Just list -> (foldl (\ a b -> max a (srcSpanEndLine' (getLoc b))) 0 list) + 1 Nothing -> case hsmodName pr of Nothing -> 0- Just mn -> srcSpanEndLine (getLoc mn) + 2+ Just mn -> srcSpanEndLine' (getLoc mn) + 2 return (ServerHeader (Right i)) Right (_pr@HsModule{ hsmodImports = imports }) -> return (ServerHeader (Left (transformImports imports))) @@ -72,16 +76,42 @@ Just (hide, list) -> Just (ImportSpecList hide (mapMaybe transformEntity list)) transformEntity :: LIE RdrName -> Maybe ImportSpec+#if MIN_VERSION_ghc(7,2,0)+transformEntity (L _ (IEVar name)) = Just (IVar (showSDoc (pprPrefixOcc name)))+#else transformEntity (L _ (IEVar name)) = Just (IVar (showSDoc (pprHsVar name)))+#endif transformEntity (L _ (IEThingAbs name)) = Just (IAbs (showRdrName name)) transformEntity (L _ (IEThingAll name)) = Just (IThingAll (showRdrName name)) transformEntity (L _ (IEThingWith name list)) = Just (IThingWith (showRdrName name) (map showRdrName list)) transformEntity _ = Nothing +#if MIN_VERSION_ghc(7,2,0) srcSpanToLocation :: SrcSpan -> Location+srcSpanToLocation (RealSrcSpan span')+ = Location (srcSpanStartLine span') (srcSpanStartCol span')+ (srcSpanEndLine span') (srcSpanEndCol span')+srcSpanToLocation _ = error "srcSpanToLocation: unhelpful span"++srcSpanStartLine' :: SrcSpan -> Int+srcSpanStartLine' (RealSrcSpan span) = srcSpanStartLine span+srcSpanStartLine' _ = error "srcSpanStartLine': unhelpful span"++srcSpanEndLine' :: SrcSpan -> Int+srcSpanEndLine' (RealSrcSpan span) = srcSpanEndLine span+srcSpanEndLine' _ = error "srcSpanEndLine': unhelpful span"+#else+srcSpanToLocation :: SrcSpan -> Location srcSpanToLocation span' | not (isGoodSrcSpan span') = error "srcSpanToLocation: unhelpful span" srcSpanToLocation span' = Location (srcSpanStartLine span') (srcSpanStartCol span') (srcSpanEndLine span') (srcSpanEndCol span')++srcSpanStartLine' :: SrcSpan -> Int+srcSpanStartLine' = srcSpanStartLine++srcSpanEndLine' :: SrcSpan -> Int+srcSpanEndLine' = srcSpanEndLine+#endif
src/IDE/Metainfo/Collector.hs view
@@ -58,7 +58,7 @@ (removeFile, doesFileExist, removeDirectoryRecursive, doesDirectoryExist) import IDE.Metainfo.SourceCollectorH (PackageCollectStats(..))-import Control.Monad.Trans (liftIO)+import Control.Monad.IO.Class (MonadIO(..)) -- -------------------------------------------------------------------- -- Command line options
src/IDE/Metainfo/InterfaceCollector.hs view
@@ -23,8 +23,18 @@ import Module hiding (PackageId,ModuleName) import qualified Module as Module (ModuleName) import qualified Maybes as M+#if MIN_VERSION_ghc(7,2,0)+import HscTypes+import GhcMonad hiding (liftIO)+import qualified GhcMonad as Hs (liftIO)+#else import HscTypes hiding (liftIO) import qualified HscTypes as Hs (liftIO)+#endif+#if MIN_VERSION_ghc(7,3,0)+import Avail+import TysWiredIn ( eqTyConName )+#endif import LoadIface import Outputable hiding(trace) import IfaceSyn@@ -107,9 +117,15 @@ extractExportedDescrH pid iface = let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface) exportedNames = Set.fromList+#if MIN_VERSION_Cabal(1,11,0)+ $ map (occNameString . nameOccName)+ $ concatMap availNames+ $ mi_exports iface+#else $ map occNameString $ concatMap availNames $ concatMap snd (mi_exports iface)+#endif exportedDecls = filter (\ ifdecl -> (occNameString $ ifName ifdecl) `Set.member` exportedNames) (map snd (mi_decls iface))@@ -123,9 +139,15 @@ extractExportedDescrR pid hidden iface = let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface) exportedNames = Set.fromList- $map occNameString- $concatMap availNames- $concatMap snd (mi_exports iface)+#if MIN_VERSION_Cabal(1,11,0)+ $ map (occNameString . nameOccName)+ $ concatMap availNames+ $ mi_exports iface+#else+ $ map occNameString+ $ concatMap availNames+ $ concatMap snd (mi_exports iface)+#endif exportedDecls = filter (\ ifdecl -> (occNameString $ifName ifdecl) `Set.member` exportedNames) (map snd (mi_decls iface))@@ -135,8 +157,9 @@ $ filter (\k -> (dscName k) `Set.member` otherDecls) hidden inst = concatMap (extractInstances (PM pid mid)) (mi_insts iface) uses = Map.fromList $ map extractUsages (mi_usages iface)- declsWithExp = map (\ (Real decl) -> Real $ decl{dscExported' =- Set.member (dscName' decl) exportedNames}) ownDecls+ declsWithExp = map withExp ownDecls+ withExp (Real d) = Real $ d{dscExported' = Set.member (dscName' d) exportedNames}+ withExp _ = error "Unexpected Reexported" in ModuleDescr { mdModuleId = PM pid mid , mdMbSourcePath = Nothing@@ -164,7 +187,11 @@ (IfaceId _ _ _) #endif -> map Real [descr]+#if MIN_VERSION_Cabal(1,11,0)+ (IfaceData name _ _ ifCons' _ _ _)+#else (IfaceData name _ _ ifCons' _ _ _ _)+#endif -> let d = case ifCons' of IfDataTyCon _decls -> let@@ -185,7 +212,11 @@ _ -> error $ "InterfaceCollector >> extractIdentifierDescr: " ++ "Newtype with not exactly one constructor" in NewtypeDescr constructor mbField+#if MIN_VERSION_ghc(7,3,0)+ IfAbstractTyCon _ -> DataDescr [] []+#else IfAbstractTyCon -> DataDescr [] []+#endif IfOpenDataTyCon -> DataDescr [] [] in [Real (descr{dscTypeHint' = d})] (IfaceClass context _ _ _ _ ifSigs' _ )@@ -210,7 +241,11 @@ (t:ts) -> fsep (t : map (arrow <+>) ts) [] -> panic "pp_con_taus" pp_res_ty decl = ppr name <+> fsep [ppr tv | (tv,_) <- ifConUnivTvs decl]+#if MIN_VERSION_ghc(7,3,0)+ eq_ctxt decl = [IfaceTyConApp (IfaceTc eqTyConName) [(IfaceTyVar (occNameFS tv)), ty]+#else eq_ctxt decl = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)+#endif | (tv,ty) <- ifConEqSpec decl] extractFields :: IfaceConDecl -> [SimpleDescr]@@ -231,8 +266,11 @@ extractSuperClassNames :: [IfacePredType] -> [String] extractSuperClassNames l = catMaybes $ map extractSuperClassName l- where extractSuperClassName (IfaceClassP name _) =+ where+#if !MIN_VERSION_ghc(7,3,0)+ extractSuperClassName (IfaceClassP name _) = Just (unpackFS $occNameFS $ nameOccName name)+#endif extractSuperClassName _ = Nothing extractInstances :: PackModule -> IfaceInst -> [Descr]@@ -253,10 +291,18 @@ extractUsages :: Usage -> (ModuleName, Set String)+#if MIN_VERSION_Cabal(1,11,0)+extractUsages (UsagePackageModule usg_mod' _ _) =+#else extractUsages (UsagePackageModule usg_mod' _ ) =+#endif let name = (fromJust . simpleParse . moduleNameString) (moduleName usg_mod') in (name, Set.fromList [])+#if MIN_VERSION_Cabal(1,11,0)+extractUsages (UsageHomeModule usg_mod_name' _ usg_entities' _ _) =+#else extractUsages (UsageHomeModule usg_mod_name' _ usg_entities' _) =+#endif let name = (fromJust . simpleParse . moduleNameString) usg_mod_name' ids = map (showSDocUnqual . ppr . fst) usg_entities' in (name, Set.fromList ids)
src/IDE/Metainfo/PackageCollector.hs view
@@ -31,7 +31,6 @@ descrType, dscName, Descr, ModuleDescr(..), PackModule(..), PackageDescr(..), metadataVersion, leksahVersion, packageIdentifierToString)-import Control.Monad.Trans (MonadIO, MonadIO(..)) import IDE.Utils.FileUtils (getCollectorPath) import System.Directory (doesFileExist, setCurrentDirectory) import IDE.Utils.Utils@@ -56,6 +55,9 @@ #endif #endif import Prelude hiding(catch)+import Control.Monad.IO.Class (MonadIO, MonadIO(..))+import qualified Control.Exception as NewException (SomeException, catch)+import IDE.Utils.Tool (runTool') collectPackage :: Bool -> Prefs -> Int -> (PackageConfig,Int) -> IO PackageCollectStats collectPackage writeAscii prefs numPackages (packageConfig, packageIndex) = do@@ -80,6 +82,7 @@ return (stat {withSource=True, retrieved= True, mbError=Nothing}) else do debugM "leksah-server" $ "collectPackage: Can't retreive = " ++ packageName+ runCabalConfigure fpSource packageDescrHi <- collectPackageFromHI packageConfig mbPackageDescrPair <- packageFromSource fpSource packageConfig case mbPackageDescrPair of@@ -90,6 +93,7 @@ writeExtractedPackage False packageDescrHi return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} BuildThenRetrieve -> do+ runCabalConfigure fpSource mbPackageDescrPair <- packageFromSource fpSource packageConfig case mbPackageDescrPair of (Just packageDescrS,bstat) -> do@@ -108,6 +112,7 @@ writeExtractedPackage False packageDescrHi return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} NeverRetrieve -> do+ runCabalConfigure fpSource packageDescrHi <- collectPackageFromHI packageConfig mbPackageDescrPair <- packageFromSource fpSource packageConfig case mbPackageDescrPair of@@ -145,6 +150,13 @@ let mergedPackageDescr = mergePackageDescrs packageDescrHi packageDescrS liftIO $ writeExtractedPackage writeAscii mergedPackageDescr liftIO $ writePackagePath (dropFileName fpSource) packageName+ runCabalConfigure fpSource = do+ let dirPath = dropFileName fpSource+ setCurrentDirectory dirPath+ NewException.catch (runTool' "cabal" (["configure","--user"]) Nothing >> return ())+ (\ (_e :: NewException.SomeException) -> do+ debugM "leksah-server" "Can't configure"+ return ()) writeExtractedPackage :: MonadIO m => Bool -> PackageDescr -> m () writeExtractedPackage writeAscii pd = do
src/IDE/Metainfo/SourceCollectorH.hs view
@@ -64,7 +64,7 @@ import qualified Control.Exception as NewException (SomeException, catch) import IDE.Utils.Tool import Control.Monad (unless)-import IDE.Utils.FileUtils (figureOutGhcOpts, figureOutHaddockOpts,myCanonicalizePath)+import IDE.Utils.FileUtils (figureOutGhcOpts, myCanonicalizePath) import Distribution.Package(PackageIdentifier) import GHC hiding(Id,Failed,Succeeded,ModuleName) import System.Log.Logger (warningM, debugM)@@ -104,11 +104,7 @@ findSourceForPackage prefs packageConfig = do sourceMap <- liftIO $ getSourcesMap prefs case sourceForPackage (getThisPackage packageConfig) sourceMap of- Just fpSource -> do- let dirPath = dropFileName fpSource- setCurrentDirectory dirPath- runTool' "cabal" (["configure","--user"]) Nothing- return (Right fpSource)+ Just fpSource -> return (Right fpSource) Nothing -> do unpackDir <- getUnpackDirectory prefs case unpackDir of@@ -121,13 +117,7 @@ success <- doesDirectoryExist (fpUnpack </> packageName) if not success then return (Left "Failed to download and unpack source")- else do- setCurrentDirectory (fpUnpack </> packageName)- NewException.catch (runTool' "cabal" (["configure","--user"]) Nothing >> return ())- (\ (_e :: NewException.SomeException) -> do- debugM "leksah-server" "Can't configure"- return ())- return (Right (fpUnpack </> packageName </> takeWhile (/= '-') packageName <.> "cabal"))+ else return (Right (fpUnpack </> packageName </> takeWhile (/= '-') packageName <.> "cabal")) where packageName = packageIdentifierToString (getThisPackage packageConfig) @@ -185,6 +175,9 @@ (ifaceInstances interface) [] --(ifaceLocals interface) imports = Map.empty --TODO +#if MIN_VERSION_ghc(7,4,1)+type DeclInfo = [LHsDecl Name]+#endif #if MIN_VERSION_ghc(6,12,1) extractDescrs :: PackModule -> Map Name DeclInfo -> [ExportItem Name] -> [Instance] -> [Name] -> [Descr] extractDescrs pm _ifaceDeclMap ifaceExportItems' ifaceInstances' _ifaceLocals =@@ -213,7 +206,11 @@ transformToDescrs :: PackModule -> [(LHsDecl Name, Maybe NDoc, [(Name, Maybe NDoc)])] -> [Descr] transformToDescrs pm = concatMap transformToDescr where+#if MIN_VERSION_ghc(7,2,0)+ transformToDescr ((L loc (SigD (TypeSig [name] typ))), mbComment,_subCommentList) =+#else transformToDescr ((L loc (SigD (TypeSig name typ))), mbComment,_subCommentList) =+#endif [Real $ RealDescr { dscName' = getOccString (unLoc name) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr typ))@@ -271,7 +268,7 @@ derivings Nothing = [] derivings (Just _l) = [] - transformToDescr ((L loc (TyClD cl@(ClassDecl _ tcdLName' _ _ tcdSigs' _ _ docs))), mbComment,_subCommentList) =+ transformToDescr ((L loc (TyClD cl@(ClassDecl{tcdLName=tcdLName', tcdSigs=tcdSigs', tcdDocs=docs}))), mbComment,_subCommentList) = [Real $ RealDescr { dscName' = getOccString (unLoc tcdLName') , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr cl{tcdMeths = emptyLHsBinds}))@@ -303,7 +300,11 @@ in mapMaybe extractMethod pairs extractMethod :: (LHsDecl Name, Maybe NDoc) -> Maybe SimpleDescr+#if MIN_VERSION_ghc(7,2,0)+extractMethod ((L loc (SigD ts@(TypeSig [name] _typ))), mbDoc) =+#else extractMethod ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) =+#endif Just $ SimpleDescr (getOccString (unLoc name)) (Just (BS.pack (showSDocUnqual $ ppr ts)))@@ -371,7 +372,7 @@ showsPrec _ (PPDoc (DocString str)) = showString str showsPrec _ (PPDoc (DocParagraph d)) = shows (PPDoc d) . showChar '\n' showsPrec _ (PPDoc (DocIdentifier l)) = foldr (\i _f -> showChar '\'' .- ((showString . showSDoc . ppr) i) . showChar '\'') id l+ ((showString . showSDoc . ppr) i) . showChar '\'') id [l] showsPrec _ (PPDoc (DocModule str)) = showChar '"' . showString str . showChar '"' showsPrec _ (PPDoc (DocEmphasis doc)) = showChar '/' . shows (PPDoc doc) . showChar '/' showsPrec _ (PPDoc (DocMonospaced doc)) = showChar '@' . shows (PPDoc doc) . showChar '@'
src/IDE/Metainfo/SourceDB.hs view
@@ -88,13 +88,12 @@ Nothing -> sourceDirs cabalFiles <- mapM allCabalFiles dirs fCabalFiles <- mapM myCanonicalizePath $ concat cabalFiles- mbPackages <- mapM (\fp -> parseCabal fp) fCabalFiles- let pdToFiles = Map.fromListWith (++)- $ map (\(Just p,o ) -> (p,o))- $ filter (\(mb, _) -> case mb of- Nothing -> False- _ -> True )- $ zip mbPackages (map (\a -> [a]) fCabalFiles)+ mbPackAndFiles <- mapM (\fp -> do+ mb <- parseCabal fp+ case mb of+ Just s -> return $ Just (s, [fp])+ Nothing -> return Nothing) fCabalFiles+ let pdToFiles = Map.fromListWith (++) $ catMaybes mbPackAndFiles filePath <- getConfigFilePathForSave standardSourcesFilename writeFile filePath (PP.render (showSourceForPackageDB pdToFiles))
src/IDE/Metainfo/WorkspaceCollector.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -XScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.WorkspaceCollector@@ -32,7 +32,9 @@ import IDE.Utils.Utils import IDE.Utils.GHCUtils import GHC hiding(Id,Failed,Succeeded,ModuleName)+#if !MIN_VERSION_ghc(7,2,0) import HscTypes hiding (liftIO)+#endif import Outputable hiding(trace) import ErrUtils import qualified Data.Map as Map@@ -41,7 +43,6 @@ import Distribution.Package hiding (PackageId) import Distribution.ModuleName import Distribution.Text (simpleParse)-import Control.Monad.Reader import System.FilePath import qualified Data.ByteString.Char8 as BS import Data.Binary.Shared@@ -62,13 +63,15 @@ import qualified Maybes as M import IDE.Metainfo.InterfaceCollector import Data.Maybe- (isJust, fromJust, catMaybes, mapMaybe, isNothing)+ (isJust, catMaybes, mapMaybe, isNothing) import Module (stringToPackageId) import PrelNames import System.Log.Logger import Control.DeepSeq (deepseq) #if MIN_VERSION_ghc(6,12,1) import FastString(mkFastString,appendFS,nullFS,unpackFS)+import Control.Monad.IO.Class (MonadIO, MonadIO(..))+import Control.Monad (when) #else import GHC.Show(showSpace) #endif@@ -145,7 +148,11 @@ collectModule' sourcePath destPath writeAscii packId opts moduleName' = gcatch ( inGhcIO (opts++["-cpp"]) [Opt_Haddock] $ \ _dynFlags -> do session <- getSession+#if MIN_VERSION_ghc(7,2,0)+ (dynFlags3,fp') <- liftIO $ preprocess session (sourcePath,Nothing)+#else (dynFlags3,fp') <- preprocess session (sourcePath,Nothing)+#endif mbInterfaceDescr <- mayGetInterfaceDescription packId moduleName' liftIO $ do stringBuffer <- hGetStringBuffer fp'@@ -325,13 +332,23 @@ notDocDecl _ = True finishedDoc _ _ rest = rest +#if MIN_VERSION_ghc(7,2,0)+sigNameNoLoc :: Sig name -> Maybe name+-- Used only in Haddock+sigNameNoLoc (TypeSig [n] _) = Just (unLoc n)+sigNameNoLoc (SpecSig n _ _) = Just (unLoc n)+sigNameNoLoc (InlineSig n _) = Just (unLoc n)+sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)+sigNameNoLoc _ = Nothing+#endif+ attachSignatures :: [(NDecl, (Maybe NDoc))] -> [(NDecl,Maybe NDoc)] -> [(NDecl, (Maybe NDoc), [(NSig,Maybe NDoc)])] attachSignatures signatures = map (attachSignature signaturesMap) where- signaturesMap = Map.fromListWith (++)- $ map (\ (L loc (SigD sig),c) -> (fromJust $ sigNameNoLoc sig, [(L loc sig,c)]))- signatures+ signaturesMap = Map.fromListWith (++) $ map sigMap signatures+ sigMap (L loc (SigD sig),c) | Just name <- sigNameNoLoc sig = (name, [(L loc sig,c)])+ sigMap _ = error "Unexpected location type" attachSignature :: Map RdrName [(NSig,Maybe NDoc)] -> (NDecl, (Maybe NDoc)) -> (NDecl, (Maybe NDoc), [(NSig,Maybe NDoc)]) attachSignature signaturesMap' (decl,mbDoc) =@@ -406,7 +423,7 @@ derivings Nothing = [] derivings (Just l) = map (extractDeriving pm name) l - transformToDescr ((L loc (TyClD cl@(ClassDecl _ tcdLName' _ _ tcdSigs' _ _ docs))), mbComment,_sigList) =+ transformToDescr ((L loc (TyClD cl@(ClassDecl{tcdLName=tcdLName', tcdSigs=tcdSigs', tcdDocs=docs}))), mbComment,_sigList) = [Real $ RealDescr { dscName' = showRdrName (unLoc tcdLName') , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr cl{tcdMeths = emptyLHsBinds}))@@ -487,7 +504,11 @@ in mapMaybe extractMethod pairs extractMethod :: OutputableBndr alpha => (LHsDecl alpha, Maybe (NDoc)) -> Maybe SimpleDescr+#if MIN_VERSION_ghc(7,2,0)+extractMethod ((L loc (SigD ts@(TypeSig [name] _typ))), mbDoc) =+#else extractMethod ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) =+#endif Just $ SimpleDescr ((showSDoc . ppr) (unLoc name)) (Just (BS.pack (showSDocUnqual $ ppr ts)))@@ -532,11 +553,18 @@ sigToByteString ((sig,_):_) = Just (BS.pack (showSDocUnqual $ppr sig)) srcSpanToLocation :: SrcSpan -> Maybe Location+#if MIN_VERSION_ghc(7,2,0)+srcSpanToLocation (RealSrcSpan span')+ = Just (Location (srcSpanStartLine span') (srcSpanStartCol span')+ (srcSpanEndLine span') (srcSpanEndCol span'))+srcSpanToLocation _ = Nothing+#else srcSpanToLocation span' | not (isGoodSrcSpan span') = Nothing srcSpanToLocation span' = Just (Location (srcSpanStartLine span') (srcSpanStartCol span') (srcSpanEndLine span') (srcSpanEndCol span'))+#endif toComment :: Maybe (NDoc) -> [NDoc] -> Maybe ByteString toComment (Just c) _ = Just (BS.pack (printHsDoc c))
src/IDE/Utils/FileUtils.hs view
@@ -17,6 +17,7 @@ allModules , allHiFiles , allHaskellSourceFiles+, isEmptyDirectory , cabalFileName , allCabalFiles , getConfigFilePathForLoad@@ -44,7 +45,7 @@ import System.FilePath (splitFileName, dropExtension, takeExtension,- combine, addExtension, (</>), normalise, splitPath)+ combine, addExtension, (</>), normalise, splitPath, takeFileName) import Distribution.ModuleName (toFilePath, ModuleName) import Control.Monad (foldM, filterM) import Data.Maybe (catMaybes)@@ -69,15 +70,7 @@ import Data.List (isPrefixOf, isSuffixOf, stripPrefix) import qualified Data.Set as Set (empty, fromList)-import Control.Monad.Trans (MonadIO(..)) import Distribution.Package (PackageIdentifier)-#ifdef MIN_VERSION_process_leksah-import IDE.System.Process- (waitForProcess, runCommand)-#else-import System.Process- (waitForProcess, runCommand)-#endif import Data.Char (ord) import Distribution.Text (simpleParse) @@ -86,6 +79,7 @@ import qualified Distribution.Text as T (simpleParse) import System.Log.Logger(errorM,warningM,debugM) import IDE.Utils.Tool+import Control.Monad.IO.Class (MonadIO(..), MonadIO) haskellSrcExts :: [String] haskellSrcExts = ["hs","lhs","chs","hs.pp","lhs.pp","chs.pp","hsc"]@@ -311,6 +305,16 @@ let nameList = map dropExtension $filter (\s -> leksahMetadataSystemFileExtension `isSuffixOf` s) paths return (Set.fromList nameList)) $ \ _ -> return (Set.empty)++isEmptyDirectory :: FilePath -> IO Bool+isEmptyDirectory filePath = catch (do+ exists <- doesDirectoryExist filePath+ if exists+ then do+ filesAndDirs <- getDirectoryContents filePath+ return . null $ filter (not . ("." `isPrefixOf`) . takeFileName) filesAndDirs+ else return False)+ (\_ -> return False) cabalFileName :: FilePath -> IO (Maybe FilePath) cabalFileName filePath = catch (do
src/IDE/Utils/GHCUtils.hs view
@@ -11,7 +11,7 @@ -- -- | -------------------------------------------------------------------------------- +----------------------------------------------------------------------------- module IDE.Utils.GHCUtils ( inGhcIO , getInstalledPackageInfos@@ -36,16 +36,26 @@ import FastString (mkFastString) import Lexer (mkPState,ParseResult(..),getMessages,unP) import Outputable (ppr)+#if MIN_VERSION_ghc(7,2,0)+import ErrUtils (dumpIfSet_dyn,printBagOfErrors,printBagOfWarnings,errorsFound,mkPlainErrMsg,showPass,ErrMsg(..))+import Control.Monad (unless)+#else import ErrUtils (dumpIfSet_dyn,printErrorsAndWarnings,mkPlainErrMsg,showPass,ErrMsg(..))+#endif import PackageConfig (PackageConfig) import Data.Foldable (maximumBy) import qualified Parser as P (parseModule,parseHeader) import HscStats (ppSourceStats)-import Control.Monad.Trans+#if MIN_VERSION_ghc(7,2,0)+import GhcMonad (Ghc(..))+import SrcLoc (mkRealSrcLoc)+#else import HscTypes (Ghc(..))+#endif import IDE.Utils.FileUtils (getSysLibDir) import DynFlags (dopt_set)-import System.Log.Logger(warningM, debugM)+import System.Log.Logger(debugM)+import Control.Monad.IO.Class (MonadIO(..), MonadIO) -- this should not be repeated here, why is it necessary? instance MonadIO Ghc where@@ -91,7 +101,7 @@ getInstalledPackageInfos :: Ghc [PackageConfig] getInstalledPackageInfos = do dflags1 <- getSessionDynFlags- setSessionDynFlags dflags1{flags = Opt_ReadUserPackageConf : (flags dflags1)}+ setSessionDynFlags $ dopt_set dflags1 Opt_ReadUserPackageConf pkgInfos <- case pkgDatabase dflags1 of Nothing -> return [] #if MIN_VERSION_Cabal(1,8,0)@@ -136,7 +146,11 @@ Just b -> return b Nothing -> hGetStringBuffer src_filename +#if MIN_VERSION_ghc(7,2,0)+ let loc = mkRealSrcLoc (mkFastString src_filename) 1 0+#else let loc = mkSrcLoc (mkFastString src_filename) 1 0+#endif #if MIN_VERSION_ghc(7,0,1) case unP P.parseModule (mkPState dflags buf' loc) of {@@ -148,8 +162,14 @@ POk pst rdr_module -> do { +#if MIN_VERSION_ghc(7,2,0)+ let {ms@(warnings, errors) = getMessages pst};+ printBagOfErrors dflags errors;+ unless (errorsFound dflags ms) $ printBagOfWarnings dflags warnings;+#else let {ms = getMessages pst}; printErrorsAndWarnings dflags ms;+#endif -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1); dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;@@ -164,7 +184,11 @@ myParseHeader :: FilePath -> String -> [String] -> IO (Either String (HsModule RdrName)) myParseHeader fp _str opts = inGhcIO (opts++["-cpp"]) [] $ \ _dynFlags -> do session <- getSession+#if MIN_VERSION_ghc(7,2,0)+ (dynFlags',fp') <- liftIO $ preprocess session (fp,Nothing)+#else (dynFlags',fp') <- preprocess session (fp,Nothing)+#endif liftIO $ do stringBuffer <- hGetStringBuffer fp' parseResult <- myParseModuleHeader dynFlags' fp (Just stringBuffer)@@ -191,7 +215,11 @@ Just b -> return b Nothing -> hGetStringBuffer src_filename +#if MIN_VERSION_ghc(7,2,0)+ let loc = mkRealSrcLoc (mkFastString src_filename) 1 0+#else let loc = mkSrcLoc (mkFastString src_filename) 1 0+#endif #if MIN_VERSION_ghc(7,0,1) case unP P.parseHeader (mkPState dflags buf' loc) of {@@ -203,8 +231,14 @@ POk pst rdr_module -> do { +#if MIN_VERSION_ghc(7,2,0)+ let {ms@(warnings, errors) = getMessages pst};+ printBagOfErrors dflags errors;+ unless (errorsFound dflags ms) $ printBagOfWarnings dflags warnings;+#else let {ms = getMessages pst}; printErrorsAndWarnings dflags ms;+#endif -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1); dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
src/IDE/Utils/Tool.hs view
@@ -1,506 +1,635 @@-{-# OPTIONS_GHC -XRecordWildCards -XCPP -XBangPatterns -fno-warn-orphans #-}------------------------------------------------------------------------------------ Module : IDE.Utils.Tool--- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken--- License : GPL------ Maintainer : <maintainer@leksah.org>--- Stability : provisional--- Portability :------ | Support for running external tools. Written mainly for GHCi but with--- | support for others in mind.-----------------------------------------------------------------------------------module IDE.Utils.Tool (- ToolOutput(..),- toolline,- ToolCommand(..),- ToolState(..),- toolProcess,- newToolState,- runTool,- runTool',- runInteractiveTool,- newGhci,- executeCommand,- executeGhciCommand,- quoteArg,- escapeQuotes,---- waitForChildren,--- forkChild--) where--import Control.Concurrent- (readMVar, takeMVar, putMVar, newEmptyMVar, forkIO, newChan, MVar,- Chan, writeChan, getChanContents, dupChan)-import Control.Monad (unless, when)-import Data.List (stripPrefix)-import Data.Maybe (isJust, catMaybes)-#ifdef MIN_VERSION_process_leksah-import IDE.System.Process- (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..))-import IDE.System.Process.Internals (StdStream(..))-#else-import System.Process- (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..))-import System.Process.Internals (StdStream(..))-#endif-import Control.DeepSeq-import System.Log.Logger (debugM, criticalM)-import System.Exit (ExitCode(..))-import System.IO (hGetContents, hFlush, hPutStrLn, Handle)-import Control.Applicative ((<$>))-import Data.Char (isNumber)--data ToolOutput = ToolInput String- | ToolError String- | ToolOutput String- | ToolPrompt- | ToolExit ExitCode deriving(Eq, Show)--instance NFData ExitCode where- rnf ExitSuccess = rnf ()- rnf (ExitFailure failureCode) = rnf failureCode--instance NFData ToolOutput where- rnf (ToolInput s) = rnf s- rnf (ToolError s) = rnf s- rnf (ToolOutput s) = rnf s- rnf (ToolPrompt) = rnf ()- rnf (ToolExit code) = rnf code--data ToolCommand = ToolCommand String ([ToolOutput] -> IO ())-data ToolState = ToolState {- toolProcessMVar :: MVar ProcessHandle,- outputClosed :: MVar Bool,- toolCommands :: Chan ToolCommand,- toolCommandsRead :: Chan ToolCommand,- currentToolCommand :: MVar ToolCommand}--toolProcess :: ToolState -> IO ProcessHandle-toolProcess = readMVar . toolProcessMVar--data RawToolOutput = RawToolOutput ToolOutput- | ToolOutClosed- | ToolErrClosed- | ToolClosed deriving(Eq, Show)--toolline :: ToolOutput -> String-toolline (ToolInput l) = l-toolline (ToolOutput l) = l-toolline (ToolError l) = l-toolline (ToolPrompt) = ""-toolline (ToolExit _code) = ""--quoteArg :: String -> String-quoteArg s | ' ' `elem` s = "\"" ++ (escapeQuotes s) ++ "\""-quoteArg s = s--escapeQuotes :: String -> String-escapeQuotes = foldr (\c s -> if c == '"' then '\\':c:s else c:s) ""--runTool' :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle)-runTool' fp args mbDir = do- debugM "leksah-server" $ "Start: " ++ show (fp, args)- (out,pid) <- runTool fp args mbDir- deepseq out $ waitForProcess pid- debugM "leksah-server" $ "End: " ++ show (fp, args)- return (out,pid)--runTool :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle)-runTool executable arguments mbDir = do- (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments)- { std_in = CreatePipe,- std_out = CreatePipe,- std_err = CreatePipe,- cwd = mbDir,- new_group = True }- output <- getOutputNoPrompt inp out err pid- return (output, pid)--newToolState :: IO ToolState-newToolState = do- toolProcessMVar <- newEmptyMVar- outputClosed <- newEmptyMVar- toolCommands <- newChan- toolCommandsRead <- dupChan toolCommands- currentToolCommand <- newEmptyMVar- return ToolState{..}--runInteractiveTool ::- ToolState ->- CommandLineReader ->- FilePath ->- [String] ->- IO ()-runInteractiveTool tool clr executable arguments = do- (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments)- { std_in = CreatePipe,- std_out = CreatePipe,- std_err = CreatePipe,- new_group = True }- putMVar (toolProcessMVar tool) pid- output <- getOutput clr inp out err pid- -- This is handy to show the processed output- -- forkIO $ forM_ output (putStrLn.show)- forkIO $ do- commands <- getChanContents (toolCommandsRead tool)- processCommand 0 commands inp output- return ()- where- processCommand _ [] _ _ = do- debugM "leksah-server" $ "No More Commands"- return ()- processCommand n ((command@(ToolCommand commandString handler)):remainingCommands)- inp allOutput = do- putMVar (currentToolCommand tool) command- hPutStrLn inp commandString- hFlush inp- outputChan <- newChan- outputChan' <- dupChan outputChan-- done <- newEmptyMVar- forkIO $ do- output <- fromRawOutput <$> getChanContents outputChan'- debugM "leksah-server" $ "Start Processing Tool Output for " ++ commandString- handler $ (map ToolInput (lines commandString)) ++ output- debugM "leksah-server" $ "Done Processing Tool Output for " ++ commandString- putMVar done True- return ()-- remainingOutputWithPrompt <- writeCommandOutput outputChan inp allOutput False False (outputSyncCommand clr) n- takeMVar done-- takeMVar (currentToolCommand tool)-- case remainingOutputWithPrompt of- (RawToolOutput ToolPrompt:remainingOutput) -> do- debugM "leksah-server" $ "Ready For Next Command"- processCommand (n+1) remainingCommands inp remainingOutput- [] -> do- debugM "leksah-server" $ "Tool Output Closed"- putMVar (outputClosed tool) True- _ -> do- criticalM "leksah-server" $ "This should never happen in Tool.hs"-- writeCommandOutput _ _ [] _ _ _ _ = do- criticalM "leksah-server" $ "ToolExit not found"- return []-- writeCommandOutput out inp (RawToolOutput ToolPrompt:remainingOutput) False False (Just outSyncCmd) n = do- debugM "leksah-server" $ "Pre Sync Prompt"- hPutStrLn inp $ outSyncCmd n- hFlush inp- writeCommandOutput out inp remainingOutput True False (Just outSyncCmd) n-- writeCommandOutput out inp (RawToolOutput ToolPrompt:remainingOutput) True False (Just outSyncCmd) n = do- debugM "leksah-server" $ "Unsynced Prompt"- writeCommandOutput out inp remainingOutput True False (Just outSyncCmd) n-- writeCommandOutput out inp (o@(RawToolOutput (ToolOutput line)):remainingOutput) True False (Just outSyncCmd) n = do- let synced = (isExpectedOutput clr n line)- unless synced $ writeChan out o- when synced $ debugM "leksah-server" $ "Output Sync Found"- writeCommandOutput out inp remainingOutput True synced (Just outSyncCmd) n-- writeCommandOutput out _ remainingOutput@(RawToolOutput ToolPrompt:_) _ _ _ _ = do- debugM "leksah-server" $ "Synced Prompt"- writeChan out $ RawToolOutput ToolPrompt- return remainingOutput-- writeCommandOutput out _ (o@(RawToolOutput (ToolExit _)):_) _ _ _ _ = do- debugM "leksah-server" $ "Tool Exit"- writeChan out o- return []-- writeCommandOutput out inp (o:remainingOutput) synching synched syncCmd n = do- writeChan out o- writeCommandOutput out inp remainingOutput synching synched syncCmd n--{--newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ToolState-newInteractiveTool getOutput' executable arguments = do- tool <- newToolState- runInteractiveTool tool getOutput' executable arguments- return tool--}--ghciPrompt :: String-ghciPrompt = "3KM2KWR7LZZbHdXfHUOA5YBBsJVYoCQnKX"--data CommandLineReader = CommandLineReader {- stripInitialPrompt :: String -> Maybe String,- stripFollowingPrompt :: String -> Maybe String,- errorSyncCommand :: Maybe (Int -> String),- stripExpectedError :: String -> Maybe (Int, String),- outputSyncCommand :: Maybe (Int -> String),- isExpectedOutput :: Int -> String -> Bool- }--ghciStripInitialPrompt :: String -> Maybe String-ghciStripInitialPrompt output =- case catMaybes [stripPrefix "Prelude" output, stripPrefix "*" output] of- remaining:_ ->- case dropWhile (/= '>') remaining of- '>':' ':next -> Just next- _ -> Nothing- _ -> Nothing--ghciStripFollowingPrompt :: String -> Maybe String-ghciStripFollowingPrompt = stripPrefix ghciPrompt--{--stripMarker $ marker 0 ++ "dfskfjdkl"--}--marker :: Int -> String-marker n =- take (29 - length num) "kMAKWRALZZbHdXfHUOAAYBBsJVYoC" ++ num- where num = show n--stripMarker :: String -> Maybe (Int, String)-stripMarker s =- case strip "kMAKWRALZZbHdXfHUOAAYBBsJVYoC" s of- Just (nums, rest) -> Just (read nums, rest)- Nothing -> Nothing- where- strip :: String -> String -> Maybe (String, String)- strip letters@(a:as) input@(b:bs)- | a == b = strip as bs- | otherwise = numbers letters input- strip _ _ = Nothing- numbers :: String -> String -> Maybe (String, String)- numbers (_:as) (n:ns)- | isNumber n = case numbers as ns of- Just (nums, rest) -> Just (n:nums, rest)- _ -> Nothing- | otherwise = Nothing- numbers [] input = Just ([], input)- numbers _ _ = Nothing----ghciStripExpectedError :: String -> Maybe (Int, String)-ghciStripExpectedError output =- case stripPrefix "\n<interactive>:1:" output of- Just rest ->- case span (/= ':') rest of- (cols, rest2) | cols == "0" || cols == "1" || cols == "0-28" || cols == "1-29" ->- case stripPrefix ": Not in scope: `" rest2 of- Just rest3 ->- case stripMarker rest3 of- Just (n, rest4) ->- case stripPrefix "'\n" rest4 of- Just rest5 -> Just (n, rest5)- Nothing -> Nothing- Nothing -> Nothing- Nothing -> Nothing- _ -> Nothing- Nothing -> Nothing--ghciIsExpectedOutput :: Int -> String -> Bool-ghciIsExpectedOutput n =- (==) (marker n)--ghciCommandLineReader :: CommandLineReader-ghciCommandLineReader = CommandLineReader {- stripInitialPrompt = ghciStripInitialPrompt,- stripFollowingPrompt = ghciStripFollowingPrompt,- errorSyncCommand = Just $ \n -> marker n,- stripExpectedError = ghciStripExpectedError,- outputSyncCommand = Just $ \n -> ":set prompt " ++ marker n ++ "\n:set prompt " ++ ghciPrompt,- isExpectedOutput = ghciIsExpectedOutput- }--noInputCommandLineReader :: CommandLineReader-noInputCommandLineReader = CommandLineReader {- stripInitialPrompt = const Nothing,- stripFollowingPrompt = const Nothing,- errorSyncCommand = Nothing,- stripExpectedError = \_ -> Nothing,- outputSyncCommand = Nothing,- isExpectedOutput = \_ _ -> False- }---waitTillEmpty :: Handle -> IO ()---waitTillEmpty handle = do--- ready <- hReady handle--- when ready $ do--- yield--- threadDelay 100--- yield--- waitTillEmpty handle--getOutput :: CommandLineReader -> Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]-getOutput clr inp out err pid = do- chan <- newChan- testClosed <- dupChan chan- -- hSetBuffering out NoBuffering- -- hSetBuffering err NoBuffering- foundExpectedError <- newEmptyMVar- -- Use this and the too putStr threads bellow if you want to see the raw output- -- hSetBuffering stdout NoBuffering- forkIO $ do- errors <- hGetContents err- -- forkIO $ putStr errors- readError chan (filter (/= '\r') errors) foundExpectedError- writeChan chan ToolErrClosed- forkIO $ do- output <- hGetContents out- -- forkIO $ putStr output- readOutput chan (filter (/= '\r') output) 0 foundExpectedError False- writeChan chan ToolOutClosed- forkIO $ do- output <- getChanContents testClosed- when ((ToolOutClosed `elem` output) && (ToolErrClosed `elem` output)) $ do- exitCode <- waitForProcess pid- writeChan chan (RawToolOutput (ToolExit exitCode))- writeChan chan ToolClosed- debugM "leksah-server" $ "Tool Exited " ++ show exitCode- fmap (takeWhile ((/=) ToolClosed)) $ getChanContents chan- where- readError chan errors foundExpectedError = do- case stripExpectedError clr errors of- Just (counter, unexpectedErrors) -> do- putMVar foundExpectedError counter- readError chan unexpectedErrors foundExpectedError- Nothing -> do- let (line, remaining) = break (== '\n') errors- case remaining of- [] -> return ()- _:remainingLines -> do- writeChan chan $ RawToolOutput $ ToolError line- readError chan remainingLines foundExpectedError-- readOutput chan output counter foundExpectedError errSynced = do- let stripPrompt = (if counter==0 then (stripInitialPrompt clr) else (stripFollowingPrompt clr))- let line = getOutputLine stripPrompt output- let remaining = drop (length line) output- case remaining of- [] -> do- when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line- '\n':remainingLines -> do- writeChan chan $ RawToolOutput $ ToolOutput line- readOutput chan remainingLines counter foundExpectedError errSynced- _ -> do- when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line- case stripPrompt remaining of- Just afterPrompt -> do- case (counter, errSynced, errorSyncCommand clr) of- (0, _, _) -> do- readOutput chan afterPrompt (counter+1) foundExpectedError errSynced-- (_, False, Just syncCmd) -> do- hPutStrLn inp $ syncCmd counter- hFlush inp- waitForError counter foundExpectedError- readOutput chan afterPrompt (counter+1) foundExpectedError True-- _ -> do- writeChan chan $ RawToolOutput ToolPrompt- readOutput chan afterPrompt (counter+1) foundExpectedError False-- _ -> return () -- Should never happen- getOutputLine _ [] = []- getOutputLine _ ('\n':_) = []- getOutputLine stripPrompt output@(x:xs)- | isJust (stripPrompt output) = []- | otherwise = x : (getOutputLine stripPrompt xs)- waitForError counter foundExpectedError = do- foundCount <- takeMVar foundExpectedError- when (foundCount < counter) $ waitForError counter foundExpectedError---fromRawOutput :: [RawToolOutput] -> [ToolOutput]-fromRawOutput [] = []-fromRawOutput (RawToolOutput (ToolPrompt):_) = [ToolPrompt]-fromRawOutput (RawToolOutput (ToolExit code):_) = [ToolExit code]-fromRawOutput (RawToolOutput output:xs) = output : (fromRawOutput xs)-fromRawOutput (_:xs) = fromRawOutput xs--getOutputNoPrompt :: Handle -> Handle -> Handle -> ProcessHandle -> IO [ToolOutput]-getOutputNoPrompt inp out err pid = fmap fromRawOutput $ getOutput noInputCommandLineReader inp out err pid--newGhci :: [String] -> [String] -> ([ToolOutput] -> IO ()) -> IO ToolState-newGhci buildFlags interactiveFlags startupOutputHandler = do- tool <- newToolState- writeChan (toolCommands tool) $- ToolCommand (":set prompt " ++ ghciPrompt) startupOutputHandler- debugM "leksah-server" $ "Working out GHCi options"- forkIO $ do- (output, _) <- runTool "cabal" (["build","--with-ghc=leksahecho"] ++ buildFlags) Nothing- case catMaybes $ map (findMake . toolline) output of- options:_ -> do- let newOptions = filterUnwanted options- debugM "leksah-server" $ newOptions- debugM "leksah-server" $ "Starting GHCi"- debugM "leksah-server" $ unwords (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags)- runInteractiveTool tool ghciCommandLineReader "ghci"- (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags)- _ -> do- startupOutputHandler output- putMVar (outputClosed tool) True- return tool- where- findMake [] = Nothing- findMake line@(_:xs) =- case stripPrefix "--make " line of- Nothing -> findMake xs- s -> s- filterUnwanted [] = []- filterUnwanted line@(x:xs) =- case stripPrefix "-O " line of- Nothing -> x: filterUnwanted xs- Just s -> filterUnwanted s---executeCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO ()-executeCommand tool command handler = do- writeChan (toolCommands tool) $ ToolCommand command handler--executeGhciCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO ()-executeGhciCommand tool command handler = do- if '\n' `elem` command- then executeCommand tool safeCommand $ \output -> do- handler $ fixInput $ fixOutput output- else executeCommand tool command handler- where- filteredLines = (filter safeLine (lines command))- promptCount = (length filteredLines)+1- safeCommand = (unlines ([":{"] ++ filteredLines)) ++ ":}"- safeLine ":{" = False- safeLine ":}" = False- safeLine _ = True- fixOutput ((ToolOutput line):xs) = (ToolOutput (removePrompts line line promptCount)):xs- fixOutput (x:xs) = x:(fixOutput xs)- fixOutput [] = []- fixInput = filter (\x -> (x /= ToolInput ":{") && (x /= ToolInput ":}"))- removePrompts _fullLine line 0 = line- removePrompts fullLine line n = case dropWhile ((/=) '|') line of- '|':' ':xs -> removePrompts fullLine xs (n-1)- _ -> fullLine----children :: MVar [MVar ()]---children = unsafePerformIO (newMVar [])------waitForChildren :: IO ()---waitForChildren = do--- cs <- takeMVar children--- case cs of--- [] -> return ()--- m:ms -> do--- putMVar children ms--- takeMVar m--- waitForChildren------forkChild :: IO () -> IO ThreadId---forkChild io = do--- mvar <- newEmptyMVar--- childs <- takeMVar children--- putMVar children (mvar:childs)--- forkIO (io `finally` putMVar mvar ())-+{-# OPTIONS_GHC -XRecordWildCards -XCPP -XBangPatterns -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Utils.Tool +-- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken +-- License : GPL +-- +-- Maintainer : <maintainer@leksah.org> +-- Stability : provisional +-- Portability : +-- +-- | Support for running external tools. Written mainly for GHCi but with +-- | support for others in mind. +-- +----------------------------------------------------------------------------- + +module IDE.Utils.Tool ( + ToolOutput(..), + toolline, + ToolCommand(..), + ToolState(..), + toolProcess, + newToolState, + runTool, + runTool', + runInteractiveTool, + newGhci, + newGhci', + executeCommand, + executeGhciCommand, + quoteArg, + escapeQuotes,+ runCommand,+ waitForProcess,+ interruptProcessGroupOf,+ ProcessHandle,+ getProcessExitCode,+ runInteractiveProcess,+ runProcess + +-- waitForChildren, +-- forkChild + +) where + +import Control.Concurrent + (tryTakeMVar, readMVar, takeMVar, putMVar, + newEmptyMVar, forkIO, newChan, MVar, Chan, writeChan, + getChanContents, dupChan) +import Control.Monad (forM_, when, unless) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Data.List (stripPrefix) +import Data.Maybe (catMaybes) +#ifdef MIN_VERSION_process_leksah +import IDE.System.Process + (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..),+ interruptProcessGroup, runCommand, getProcessExitCode,+ runProcess, runInteractiveProcess) +import IDE.System.Process.Internals (StdStream(..)) +#else +import System.Process + (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..),+ interruptProcessGroupOf, runCommand, getProcessExitCode,+ runProcess, runInteractiveProcess) +import System.Process.Internals (StdStream(..)) +#endif +#if MIN_VERSION_base(4,3,0)+import System.IO (hGetBufSome)+import qualified Data.ByteString.Internal as B + (createAndTrim) +#else+import System.IO (hWaitForInput, hIsEOF)+import qualified Data.ByteString as B + (hGetNonBlocking) +#endif+import Control.DeepSeq +import System.Log.Logger (debugM) +import System.Exit (ExitCode(..)) +import System.IO (hFlush, hPutStrLn, Handle, hSetBuffering, BufferMode(..)) +import Control.Applicative ((<|>), Alternative, liftA2, liftA) +--import Data.Enumerator.Binary as E (enumHandle) +import Data.Enumerator as E + (continue, tryIO, checkContinue0, (=$), (>>==), Stream(..), + Enumeratee, Enumerator, run, ($$), ($=), (>==>)) +import qualified Data.Enumerator as E + (enumList, returnI, Step(..), isEOF, checkDone, yield, + Iteratee(..), sequence, run_) +import qualified Data.Enumerator.Binary as EB (filter) +import Data.Attoparsec.Enumerator (iterParser) +import qualified Data.Attoparsec.Char8 as AP + (endOfInput, takeWhile, satisfy, skipWhile, string, Parser, + endOfLine, digit, manyTill, takeWhile1) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B (unpack, pack) +import Data.Attoparsec ((<?>)) +import qualified Data.Enumerator.List as EL + (consume, concatMap, concatMapAccumM) +import Data.Char (isDigit) +import qualified System.IO as IO (Handle) +import qualified Data.ByteString as B + (empty, null, ByteString) +import System.IO.Error (mkIOError, illegalOperationErrorType) + +data ToolOutput = ToolInput String + | ToolError String + | ToolOutput String + | ToolPrompt String + | ToolExit ExitCode deriving(Eq, Show) + +instance NFData ExitCode where + rnf ExitSuccess = rnf () + rnf (ExitFailure failureCode) = rnf failureCode + +instance NFData ToolOutput where + rnf (ToolInput s) = rnf s + rnf (ToolError s) = rnf s + rnf (ToolOutput s) = rnf s + rnf (ToolPrompt s) = rnf s + rnf (ToolExit code) = rnf code + +data ToolCommand = ToolCommand String String (E.Iteratee ToolOutput IO ()) +data ToolState = ToolState { + toolProcessMVar :: MVar ProcessHandle, + outputClosed :: MVar Bool, + toolCommands :: Chan ToolCommand, + toolCommandsRead :: Chan ToolCommand, + currentToolCommand :: MVar ToolCommand} + +toolProcess :: ToolState -> IO ProcessHandle +toolProcess = readMVar . toolProcessMVar + +data RawToolOutput = RawToolOutput ToolOutput + | ToolOutClosed + | ToolErrClosed + | ToolClosed deriving(Eq, Show) + +toolline :: ToolOutput -> String +toolline (ToolInput l) = l +toolline (ToolOutput l) = l +toolline (ToolError l) = l +toolline (ToolPrompt l) = l +toolline (ToolExit _code) = "" + +quoteArg :: String -> String +quoteArg s | ' ' `elem` s = "\"" ++ (escapeQuotes s) ++ "\"" +quoteArg s = s + +escapeQuotes :: String -> String +escapeQuotes = foldr (\c s -> if c == '"' then '\\':c:s else c:s) "" + +#ifdef MIN_VERSION_process_leksah+interruptProcessGroupOf :: ProcessHandle -> IO ()+interruptProcessGroupOf = interruptProcessGroup+#endif++runTool' :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle) +runTool' fp args mbDir = do + debugM "leksah-server" $ "Start: " ++ show (fp, args) + (out,pid) <- runTool fp args mbDir + output <- E.run_ $ out $$ EL.consume + waitForProcess pid + debugM "leksah-server" $ "End: " ++ show (fp, args) + return (output,pid) + +runTool :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> IO (Enumerator ToolOutput m b, ProcessHandle) +runTool executable arguments mbDir = do + (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments) + { std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe, + cwd = mbDir, +#ifdef MIN_VERSION_process_leksah + new_group = True } +#else + create_group = True } +#endif + output <- getOutputNoPrompt inp out err pid + return (output, pid) + +newToolState :: IO ToolState +newToolState = do + toolProcessMVar <- newEmptyMVar + outputClosed <- newEmptyMVar + toolCommands <- newChan + toolCommandsRead <- dupChan toolCommands + currentToolCommand <- newEmptyMVar + return ToolState{..} + +dropToFirst :: Monad m => (a -> Bool) -> E.Iteratee a m () +dropToFirst p = E.continue loop where + loop (Chunks xs) = case dropWhile p xs of + [] -> E.continue loop + _:xs' -> E.yield () (Chunks xs') + loop EOF = E.yield () EOF + +isolateToFirst :: Monad m => (a -> Bool) -> Enumeratee a a m b +isolateToFirst p (E.Continue k) = E.continue loop where + loop (Chunks []) = E.continue loop + loop (Chunks xs) = + case span p xs of + (_, []) -> k (Chunks xs) >>== isolateToFirst p + (s1, t:s2) -> k (Chunks (s1++[t])) >>== (\step -> E.yield step (Chunks s2)) + loop EOF = k EOF >>== (\step -> E.yield step EOF) +isolateToFirst p step = dropToFirst p >> return step + +runInteractiveTool :: + ToolState -> + CommandLineReader -> + FilePath -> + [String] -> + IO () +runInteractiveTool tool clr executable arguments = do + (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments) + { std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe, +#ifdef MIN_VERSION_process_leksah + new_group = True } +#else + create_group = True } +#endif + putMVar (toolProcessMVar tool) pid + output <- getOutput clr inp out err pid + + forkIO $ do + commands <- getChanContents (toolCommandsRead tool) + E.run_ $ output $$ outputSequence inp $$ processCommand commands inp + return () + return () + where + isEndOfCommandOutput (ToolPrompt _) = True + isEndOfCommandOutput (ToolExit _) = True + isEndOfCommandOutput _ = False + + isolateCommandOutput = isolateToFirst (not . isEndOfCommandOutput) + + processCommand [] _ = do + liftIO $ debugM "leksah-server" $ "No More Commands" + return () + processCommand ((command@(ToolCommand commandString rawCommandString handler)):remainingCommands) inp = do + liftIO $ putMVar (currentToolCommand tool) command + liftIO $ hPutStrLn inp commandString + liftIO $ hFlush inp + + (E.enumList 1 (map ToolInput (lines rawCommandString)) >==> isolateCommandOutput) =$ handler + processCommand remainingCommands inp + + outputSequence :: Handle -> E.Enumeratee RawToolOutput ToolOutput IO b + outputSequence inp = + EL.concatMapAccumM writeCommandOutput (False, False, (outputSyncCommand clr), 0, "") + where + writeCommandOutput (False, False, (Just outSyncCmd), n, _) (RawToolOutput (ToolPrompt line)) = do + debugM "leksah-server" $ "Pre Sync Prompt" + hPutStrLn inp $ outSyncCmd n + hFlush inp + return ((True, False, (Just outSyncCmd), n, line), []) + writeCommandOutput (True, False, mbSyncCmd, n, promptLine) (RawToolOutput (ToolPrompt _)) = do + debugM "leksah-server" $ "Unsynced Prompt" + return ((True, False, mbSyncCmd, n, promptLine), []) + writeCommandOutput (True, False, mbSyncCmd, n, promptLine) (RawToolOutput o@(ToolOutput line)) = do + let synced = (isExpectedOutput clr n line) + when synced $ debugM "leksah-server" $ "Output Sync Found" + return ((True, synced, mbSyncCmd, n, promptLine), if synced then [] else [o]) + writeCommandOutput (_, _, mbSyncCmd, n, promptLine) (RawToolOutput (ToolPrompt _)) = do + debugM "leksah-server" $ "Synced Prompt - Ready For Next Command" + tryTakeMVar (currentToolCommand tool) + return ((False, False, mbSyncCmd, n+1, promptLine), [ToolPrompt promptLine]) + writeCommandOutput s (RawToolOutput o@(ToolExit _)) = do + debugM "leksah-server" $ "Tool Exit" + putMVar (outputClosed tool) True + return (s, [o]) + writeCommandOutput s (RawToolOutput o) = do + return (s, [o]) + writeCommandOutput s x = do + debugM "leksah-server" $ "Unexpected output " ++ show x + return (s, []) + +{- +newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ToolState +newInteractiveTool getOutput' executable arguments = do + tool <- newToolState + runInteractiveTool tool getOutput' executable arguments + return tool +-} + +ghciPrompt :: String +ghciPrompt = "3KM2KWR7LZZbHdXfHUOA5YBBsJVYoCQnKX" + +data CommandLineReader = CommandLineReader { + parseInitialPrompt :: AP.Parser String, + parseFollowingPrompt :: AP.Parser String, + errorSyncCommand :: Maybe (Int -> String), + parseExpectedError :: AP.Parser (String, Int), + outputSyncCommand :: Maybe (Int -> String), + isExpectedOutput :: Int -> String -> Bool + } + +ghciParseInitialPrompt :: AP.Parser String +ghciParseInitialPrompt = (do + ((AP.string $ B.pack "Prelude") <|> (AP.string $ B.pack "*")) + AP.skipWhile (\c -> c /= '>' && c/= '\n') + AP.string $ B.pack "> " + return "") + <?> "ghciParseInitialPrompt" + +ghciParseFollowingPrompt :: AP.Parser String +ghciParseFollowingPrompt = (do + AP.satisfy (/='\n') `AP.manyTill` (AP.string $ B.pack $ ghciPrompt)) + <?> "ghciParseFollowingPrompt" + +marker :: Int -> String +marker n = "kMAKWRALZZbHdXfHUOAAYBB" ++ show n + +parseMarker :: AP.Parser Int +parseMarker = (do + AP.string $ B.pack "kMAKWRALZZbHdXfHUOAAYBB" + nums <- AP.takeWhile isDigit + return . read $ B.unpack nums) + <?> "parseMarker" + +ghciParseExpectedErrorCols :: AP.Parser () +ghciParseExpectedErrorCols = (do + AP.string $ B.pack "0-" + AP.digit + AP.digit + return ()) + <|> (do + AP.string $ B.pack "1-" + AP.digit + AP.digit + return ()) + <|> (do + AP.string $ B.pack "0" + return ()) + <|> (do + AP.string $ B.pack "1" + return ()) + <?> "ghciParseExpectedErrorCols" ++manyTill' :: Alternative f => f a -> f b -> f ([a], b)+manyTill' p end = scan+ where scan = liftA (\b -> ([], b)) end <|> liftA2 (\a (as, b) -> (a:as, b)) p scan+ +ghciParseExpectedError :: AP.Parser (String, Int) +ghciParseExpectedError = (do+ AP.satisfy (/='\n') `manyTill'` (do + AP.string $ B.pack "\n<interactive>:" + AP.takeWhile1 isDigit + AP.string $ B.pack ":" + ghciParseExpectedErrorCols + AP.string $ B.pack ": Not in scope: `" + result <- parseMarker + AP.string $ B.pack "'\n" + return result)) + <?> "ghciParseExpectedError" + +ghciIsExpectedOutput :: Int -> String -> Bool +ghciIsExpectedOutput n = + (==) (marker n) + +ghciCommandLineReader :: CommandLineReader +ghciCommandLineReader = CommandLineReader { + parseInitialPrompt = ghciParseInitialPrompt, + parseFollowingPrompt = ghciParseFollowingPrompt, + errorSyncCommand = Just $ \n -> marker n, + parseExpectedError = ghciParseExpectedError, + outputSyncCommand = Just $ \n -> ":set prompt \"" ++ marker n ++ "\\n\"\n:set prompt " ++ ghciPrompt, + isExpectedOutput = ghciIsExpectedOutput + } + +noInputCommandLineReader :: CommandLineReader +noInputCommandLineReader = CommandLineReader { + parseInitialPrompt = fail "No Prompt Expected", + parseFollowingPrompt = fail "No Prompt Expected", + errorSyncCommand = Nothing, + parseExpectedError = fail "No Expected Errors", + outputSyncCommand = Nothing, + isExpectedOutput = \_ _ -> False + } + +parseError :: AP.Parser (String, Int) -> AP.Parser (Either (String, Int) ByteString) +parseError expectedErrorParser = (do + expected <- expectedErrorParser + return $ Left expected) + <|> (do + line <- AP.takeWhile (/= '\n') + (AP.endOfInput <|> AP.endOfLine) + return $ Right line) + <?> "parseError" ++-- From enumerator but using hGetSome (to fix Win32) +enumHandle :: MonadIO m + => Integer -- ^ Buffer size + -> IO.Handle + -> Enumerator B.ByteString m b +enumHandle bufferSize h = checkContinue0 $ \loop k -> do + let intSize = fromInteger bufferSize + + bytes <- tryIO (hGetSome h intSize) + if B.null bytes + then continue k + else k (Chunks [bytes]) >>== loop ++-- From byteString (for GHC 6.12.3 support)+hGetSome :: Handle -> Int -> IO ByteString+hGetSome hh i+#if MIN_VERSION_base(4,3,0)+ | i > 0 = B.createAndTrim i $ \p -> hGetBufSome hh p i+#else+ | i > 0 = let+ loop = do+ s <- B.hGetNonBlocking hh i+ if not (B.null s)+ then return s+ else do eof <- hIsEOF hh+ if eof then return s+ else hWaitForInput hh (-1) >> loop+ -- for this to work correctly, the+ -- Handle should be in binary mode+ -- (see GHC ticket #3808)+ in loop+#endif+ | i == 0 = return B.empty+ | otherwise = illegalBufferSize hh "hGetSome" i++illegalBufferSize :: Handle -> String -> Int -> IO a+illegalBufferSize handle fn sz =+ ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing)+ --TODO: System.IO uses InvalidArgument here, but it's not exported :-(+ where+ msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz []+ +getOutput :: MonadIO m => CommandLineReader -> Handle -> Handle -> Handle -> ProcessHandle + -> IO (Enumerator RawToolOutput m b) +getOutput clr inp out err pid = do + hSetBuffering out NoBuffering + hSetBuffering err NoBuffering + mvar <- newEmptyMVar + foundExpectedError <- liftIO $ newEmptyMVar + forkIO $ do + readError mvar err foundExpectedError + putMVar mvar ToolErrClosed + forkIO $ do + readOutput mvar out foundExpectedError + putMVar mvar ToolOutClosed + return $ enumOutput mvar + where + enumOutput :: MonadIO m => MVar RawToolOutput -> Enumerator RawToolOutput m b + enumOutput = loop (0::Int) where + loop closed mvar (E.Continue k) | closed < 2 = do + v <- liftIO $ takeMVar mvar + let (nowClosed, chunk) = if (v == ToolOutClosed) || (v == ToolErrClosed) + then (closed + 1, []) + else (closed, [v]) + if nowClosed == 2 + then do + exitCode <- liftIO $ waitForProcess pid + k (Chunks [RawToolOutput (ToolExit exitCode)]) >>== loop nowClosed mvar + else k (Chunks chunk) >>== loop nowClosed mvar + loop _ _ step = E.returnI step + + readError :: MVar RawToolOutput -> Handle -> MVar Int -> IO () + readError mvar errors foundExpectedError = do + result <- E.run $ (enumHandle 2048 errors $= EB.filter (/= 13)) + $$ (E.sequence (iterParser $ parseError (parseExpectedError clr))) + $$ sendErrors + case result of + Left e -> putStrLn $ show e + Right _ -> return () + return () + where + sendErrors = E.continue loop + where + loop (E.Chunks xs) = do + forM_ xs $ \x -> liftIO $ do + debugM "leksah-server" $ show x + case x of + Left (line, counter) -> do+ unless (null line) $ putMVar mvar $ RawToolOutput $ ToolError line+ putMVar foundExpectedError counter + Right line -> putMVar mvar $ RawToolOutput $ ToolError (B.unpack line) + E.continue loop + loop E.EOF = E.yield () E.EOF + + outputSequence :: E.Iteratee ao IO ToolOutput -> E.Iteratee ao IO ToolOutput -> E.Enumeratee ao ToolOutput IO b + outputSequence i1 i2 = loop i1 where + loop i = E.checkDone check + where + check k = E.isEOF >>= \f -> if f + then E.yield (E.Continue k) EOF + else step k + step k = i >>= \v -> + case v of + ToolPrompt _ -> k (Chunks [v]) >>== loop i2 + _ -> k (Chunks [v]) >>== loop i + + readOutput :: MVar RawToolOutput -> Handle -> MVar Int -> IO () + readOutput mvar output foundExpectedError = do + let parseLines parsePrompt = (do + lineSoFar <- parsePrompt + return $ ToolPrompt lineSoFar) + <|> (do + line <- AP.takeWhile (/= '\n') + (AP.endOfInput <|> AP.endOfLine) + return . ToolOutput $ B.unpack line) + <?> "parseLines" + parseInitialLines = parseLines (parseInitialPrompt clr) + parseFollowinglines = parseLines (parseFollowingPrompt clr) + E.run_ $ (enumHandle 2048 output $= EB.filter (/= 13)) + $$ outputSequence (iterParser parseInitialLines) (iterParser parseFollowinglines) + $$ sendErrors + return () + where + sendErrors = E.continue (loop 0 False "") + where + loop counter errSynced promptLine (E.Chunks xs) = do + forM_ xs $ \x -> do + liftIO $ debugM "leksah-server" $ show x + case x of + ToolPrompt line -> do + case (counter, errSynced, errorSyncCommand clr) of + (0, _, _) -> do + E.continue (loop (counter+1) errSynced line) + (_, False, Just syncCmd) -> do + liftIO $ do + debugM "leksah-server" $ "sendErrors - Sync " ++ show counter + hPutStrLn inp $ syncCmd counter + hFlush inp + waitForError counter + debugM "leksah-server" $ "sendErrors - Synced " ++ show counter + E.continue (loop (counter+1) True line) + (_, True, Just _) -> do + liftIO $ putMVar mvar $ RawToolOutput (ToolPrompt promptLine) + E.continue (loop (counter+1) False promptLine) + _ -> do + liftIO $ putMVar mvar $ RawToolOutput x + E.continue (loop (counter+1) False promptLine) + _ -> do + liftIO . putMVar mvar $ RawToolOutput x + E.continue (loop counter errSynced promptLine) + loop _ _ _ E.EOF = E.yield () E.EOF + + waitForError counter = do + foundCount <- takeMVar foundExpectedError + debugM "leksah-server" $ "waitForError - Found " ++ show foundCount + when (foundCount < counter) $ waitForError counter + + +fromRawOutput :: RawToolOutput -> [ToolOutput] +fromRawOutput (RawToolOutput output) = [output] +fromRawOutput (_) = [] + +getOutputNoPrompt :: MonadIO m => Handle -> Handle -> Handle -> ProcessHandle -> IO (Enumerator ToolOutput m b) +getOutputNoPrompt inp out err pid = do + output <- getOutput noInputCommandLineReader inp out err pid + return $ output $= EL.concatMap fromRawOutput + +newGhci' :: [String] -> (E.Iteratee ToolOutput IO ()) -> IO ToolState +newGhci' flags startupOutputHandler = do + tool <- newToolState + writeChan (toolCommands tool) $ + ToolCommand (":set prompt " ++ ghciPrompt) "" startupOutputHandler + runInteractiveTool tool ghciCommandLineReader "ghci" flags + return tool + +newGhci :: [String] -> [String] -> (E.Iteratee ToolOutput IO ()) -> IO ToolState +newGhci buildFlags interactiveFlags startupOutputHandler = do + tool <- newToolState + writeChan (toolCommands tool) $ + ToolCommand (":set prompt " ++ ghciPrompt) "" startupOutputHandler + debugM "leksah-server" $ "Working out GHCi options" + forkIO $ do + (out, _) <- runTool "cabal" (["build","--with-ghc=leksahecho"] ++ buildFlags) Nothing + output <- E.run_ $ out $$ EL.consume + case catMaybes $ map (findMake . toolline) output of + options:_ -> do + let newOptions = filterUnwanted options + debugM "leksah-server" $ newOptions + debugM "leksah-server" $ "Starting GHCi" + debugM "leksah-server" $ unwords (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags) + runInteractiveTool tool ghciCommandLineReader "ghci" + (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags) + _ -> do + E.run $ E.enumList 1 output $$ startupOutputHandler + putMVar (outputClosed tool) True + return tool + where + findMake [] = Nothing + findMake line@(_:xs) = + case stripPrefix "--make " line of + Nothing -> findMake xs + s -> s + filterUnwanted [] = [] + filterUnwanted line@(x:xs) = + case stripPrefix "-O " line of + Nothing -> x: filterUnwanted xs + Just s -> filterUnwanted s + + +executeCommand :: ToolState -> String -> String -> E.Iteratee ToolOutput IO () -> IO () +executeCommand tool command rawCommand handler = do + writeChan (toolCommands tool) $ ToolCommand command rawCommand handler + +executeGhciCommand :: ToolState -> String -> E.Iteratee ToolOutput IO () -> IO () +executeGhciCommand tool command handler = do + if '\n' `elem` command + then executeCommand tool safeCommand command handler + else executeCommand tool command command handler + where + filteredLines = (filter safeLine (lines command)) + safeCommand = ":cmd (return " ++ show (":{\n" ++ unlines filteredLines ++ "\n:}") ++ ")" + safeLine ":{" = False + safeLine ":}" = False + safeLine _ = True + +--children :: MVar [MVar ()] +--children = unsafePerformIO (newMVar []) +-- +--waitForChildren :: IO () +--waitForChildren = do +-- cs <- takeMVar children +-- case cs of +-- [] -> return () +-- m:ms -> do +-- putMVar children ms +-- takeMVar m +-- waitForChildren +-- +--forkChild :: IO () -> IO ThreadId +--forkChild io = do +-- mvar <- newEmptyMVar +-- childs <- takeMVar children +-- putMVar children (mvar:childs) +-- forkIO (io `finally` putMVar mvar ()) +
+ tests/TestTool.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+--+-- Module : Main+-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- | Windows systems do not often have a real echo executable (so --with-ghc=echo fails)+--+-----------------------------------------------------------------------------++module Main (+main+) where++import System.Environment (getArgs)+import System.Exit (exitWith, exitSuccess, exitFailure, ExitCode(..))+import IDE.Utils.Tool+ (toolProcess, executeGhciCommand, ToolOutput(..), runTool',+ newGhci')+#ifdef MIN_VERSION_process_leksah+import IDE.System.Process (interruptProcessGroup, getProcessExitCode)+#else+import System.Process (interruptProcessGroupOf, getProcessExitCode)+#endif+import Test.HUnit+ ((@=?), (@?=), putTextToHandle, Counts(..), runTestTT, assertBool,+ runTestText, (~:), Testable(..), Test(..))+import System.IO (hPutStr, stdout, hPutStrLn, stderr)+import qualified Data.Enumerator.List as EL (consume)+import Control.Concurrent+ (threadDelay, forkIO, takeMVar, putMVar, newEmptyMVar)+import Control.Monad.IO.Class (liftIO)+import Control.Monad (forM_)+import System.Log.Logger+ (setLevel, rootLoggerName, updateGlobalLogger)+import System.Log (Priority(..))++runSelf' args = runTool' "dist/build/test-tool/test-tool" args Nothing++-- stderr and stdout may not be in sync+check output expected = do+ checkFiltered notOut+ checkFiltered notErr+ where+ checkFiltered f = filter f output @?= filter f expected+ notErr (ToolError _) = False+ notErr _ = True+ notOut (ToolOutput _) = False+ notOut _ = True++runTests testMVar = loop+ where+ loop = do+ mbTest <- takeMVar testMVar+ case mbTest of+ Just test -> do+ test+ loop+ Nothing -> return ()++sendTest testMVar test = do+ liftIO $ putMVar testMVar $ Just test++doneTesting testMVar = do+ liftIO $ putMVar testMVar $ Nothing++tests = test [+ "Exit Success" ~: do+ (output, _) <- runSelf' ["ExitSuccess"]+ output `check` [ToolExit ExitSuccess],+ "Exit Failure" ~: do+ (output, _) <- runSelf' ["Exit42"]+ output `check` [ToolExit (ExitFailure 42)],+ "Single Blank Out Line" ~: do+ (output, _) <- runSelf' ["BlankLine", "StdOut"]+ output `check` [ToolOutput "", ToolExit ExitSuccess],+ "Single Blank Err Line" ~: do+ (output, _) <- runSelf' ["BlankLine", "StdErr"]+ output `check` [ToolError "", ToolExit ExitSuccess],+ "Hello Out" ~: do+ (output, _) <- runSelf' ["Hello", "StdOut"]+ output `check` [ToolOutput "Hello World", ToolExit ExitSuccess],+ "Hello Err" ~: do+ (output, _) <- runSelf' ["Hello", "StdErr"]+ output `check` [ToolError "Hello World", ToolExit ExitSuccess],+ "Both" ~: do+ (output, _) <- runSelf' ["ErrAndOut"]+ output `check` [ToolError "Error", ToolOutput "Output", ToolExit ExitSuccess],+ "Unterminated Out" ~: do+ (output, _) <- runSelf' ["Unterminated", "StdOut"]+ output `check` [ToolOutput "Unterminated", ToolExit ExitSuccess],+ "Unterminated Err" ~: do+ (output, _) <- runSelf' ["Unterminated", "StdErr"]+ output `check` [ToolError "Unterminated", ToolExit ExitSuccess],+ "GHCi Failed Sart" ~: do+ t <- newEmptyMVar+ tool <- newGhci' ["MissingFile.hs"] $ do+ output <- EL.consume+ sendTest t $ last output @?= (ToolPrompt "")+ executeGhciCommand tool ":quit" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput ":quit",+ ToolOutput "Leaving GHCi.",+ ToolExit ExitSuccess],+ "GHCi" ~: do+ t <- newEmptyMVar+ tool <- newGhci' [] $ do+ output <- EL.consume+ sendTest t $ last output @?= (ToolPrompt "")+ executeGhciCommand tool ":m +System.IO" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput ":m +System.IO",+ ToolPrompt ""]+ executeGhciCommand tool "hPutStr stderr \"Test\"" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput "hPutStr stderr \"Test\"",+ ToolError "Test",+ ToolPrompt ""]+ executeGhciCommand tool "1+1" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput "1+1",+ ToolOutput "2",+ ToolPrompt ""]+ executeGhciCommand tool "jfkdfjdkl" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput "jfkdfjdkl",+ ToolError "",+#if __GLASGOW_HASKELL__ > 702+ ToolError "<interactive>:22:1: Not in scope: `jfkdfjdkl'",+#else+ ToolError "<interactive>:1:1: Not in scope: `jfkdfjdkl'",+#endif+ ToolPrompt ""]+ executeGhciCommand tool "\n1+1" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput "",+ ToolInput "1+1",+ ToolOutput "2",+ ToolPrompt ""]+ executeGhciCommand tool ":m + Prelude" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput ":m + Prelude",+ ToolPrompt ""]+ executeGhciCommand tool "\njfkdfjdkl" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput "",+ ToolInput "jfkdfjdkl",+ ToolError "",+#if __GLASGOW_HASKELL__ > 702+ ToolError "<interactive>:37:1: Not in scope: `jfkdfjdkl'",+#else+ ToolError "<interactive>:1:1: Not in scope: `jfkdfjdkl'",+#endif+ ToolPrompt ""]+ executeGhciCommand tool "do\n putStrLn \"1\"\n putStrLn \"2\"\n putStrLn \"3\"\n putStrLn \"4\"\n putStrLn \"5\"\n" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput "do",+ ToolInput " putStrLn \"1\"",+ ToolInput " putStrLn \"2\"",+ ToolInput " putStrLn \"3\"",+ ToolInput " putStrLn \"4\"",+ ToolInput " putStrLn \"5\"",+ ToolOutput "1",+ ToolOutput "2",+ ToolOutput "3",+ ToolOutput "4",+ ToolOutput "5",+ ToolPrompt ""]+ executeGhciCommand tool "do\n putStrLn \"| 1\"\n putStrLn \"| 2\"\n putStrLn \"| 3\"\n putStrLn \"| 4\"\n putStrLn \"| 5\"\n" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput "do",+ ToolInput " putStrLn \"| 1\"",+ ToolInput " putStrLn \"| 2\"",+ ToolInput " putStrLn \"| 3\"",+ ToolInput " putStrLn \"| 4\"",+ ToolInput " putStrLn \"| 5\"",+ ToolOutput "| 1",+ ToolOutput "| 2",+ ToolOutput "| 3",+ ToolOutput "| 4",+ ToolOutput "| 5",+ ToolPrompt ""]+ executeGhciCommand tool "putStr \"ABC\"" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput "putStr \"ABC\"",+ ToolPrompt "ABC"]+ executeGhciCommand tool ":m +Data.List" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput ":m +Data.List",+ ToolPrompt ""]+ executeGhciCommand tool ":quit" $ do+ output <- EL.consume+ sendTest t $ output `check` [+ ToolInput ":quit",+ ToolOutput "Leaving GHCi.",+ ToolExit ExitSuccess]+ runTests t]++main :: IO ()+main = do+ args <- getArgs+ case args of+ [] -> do+ updateGlobalLogger rootLoggerName (\ l -> setLevel DEBUG l)+ (Counts{failures=failures}, _) <- runTestText (putTextToHandle stderr False) tests+ if failures == 0+ then exitSuccess+ else exitFailure+ ["ExitSuccess"] -> exitSuccess+ ["Exit42"] -> exitWith (ExitFailure 42)+ ["BlankLine", o] -> hPutStrLn (h o) ""+ ["Hello", o] -> hPutStrLn (h o) "Hello World"+ ["ErrAndOut"] -> hPutStrLn stderr "Error" >> hPutStrLn stdout "Output"+ ["Unterminated", o] -> hPutStr (h o) "Unterminated"+ _ -> exitFailure+ where+ h "StdErr" = stderr+ h _ = stdout