diff --git a/data/prefscoll.lkshp b/data/prefscoll.lkshp --- a/data/prefscoll.lkshp +++ b/data/prefscoll.lkshp @@ -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: diff --git a/leksah-server.cabal b/leksah-server.cabal --- a/leksah-server.cabal +++ b/leksah-server.cabal @@ -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 diff --git a/src/IDE/Core/CTypes.hs b/src/IDE/Core/CTypes.hs --- a/src/IDE/Core/CTypes.hs +++ b/src/IDE/Core/CTypes.hs @@ -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) diff --git a/src/IDE/HeaderParser.hs b/src/IDE/HeaderParser.hs --- a/src/IDE/HeaderParser.hs +++ b/src/IDE/HeaderParser.hs @@ -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 diff --git a/src/IDE/Metainfo/Collector.hs b/src/IDE/Metainfo/Collector.hs --- a/src/IDE/Metainfo/Collector.hs +++ b/src/IDE/Metainfo/Collector.hs @@ -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 diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs --- a/src/IDE/Metainfo/InterfaceCollector.hs +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -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) diff --git a/src/IDE/Metainfo/PackageCollector.hs b/src/IDE/Metainfo/PackageCollector.hs --- a/src/IDE/Metainfo/PackageCollector.hs +++ b/src/IDE/Metainfo/PackageCollector.hs @@ -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 diff --git a/src/IDE/Metainfo/SourceCollectorH.hs b/src/IDE/Metainfo/SourceCollectorH.hs --- a/src/IDE/Metainfo/SourceCollectorH.hs +++ b/src/IDE/Metainfo/SourceCollectorH.hs @@ -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 '@' diff --git a/src/IDE/Metainfo/SourceDB.hs b/src/IDE/Metainfo/SourceDB.hs --- a/src/IDE/Metainfo/SourceDB.hs +++ b/src/IDE/Metainfo/SourceDB.hs @@ -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)) diff --git a/src/IDE/Metainfo/WorkspaceCollector.hs b/src/IDE/Metainfo/WorkspaceCollector.hs --- a/src/IDE/Metainfo/WorkspaceCollector.hs +++ b/src/IDE/Metainfo/WorkspaceCollector.hs @@ -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)) diff --git a/src/IDE/Utils/FileUtils.hs b/src/IDE/Utils/FileUtils.hs --- a/src/IDE/Utils/FileUtils.hs +++ b/src/IDE/Utils/FileUtils.hs @@ -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 diff --git a/src/IDE/Utils/GHCUtils.hs b/src/IDE/Utils/GHCUtils.hs --- a/src/IDE/Utils/GHCUtils.hs +++ b/src/IDE/Utils/GHCUtils.hs @@ -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) ; diff --git a/src/IDE/Utils/Tool.hs b/src/IDE/Utils/Tool.hs --- a/src/IDE/Utils/Tool.hs +++ b/src/IDE/Utils/Tool.hs @@ -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 : --- 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: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 : +-- 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:" + 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 ()) + diff --git a/tests/TestTool.hs b/tests/TestTool.hs new file mode 100644 --- /dev/null +++ b/tests/TestTool.hs @@ -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 ":22:1: Not in scope: `jfkdfjdkl'", +#else + ToolError ":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 ":37:1: Not in scope: `jfkdfjdkl'", +#else + ToolError ":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