diff --git a/leksah-server.cabal b/leksah-server.cabal --- a/leksah-server.cabal +++ b/leksah-server.cabal @@ -1,5 +1,5 @@ name: leksah-server -version: 0.12.1.2 +version: 0.13.1.0 cabal-version: >= 1.10.2 build-type: Simple license: GPL @@ -32,43 +32,48 @@ 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.1.0 && <0.13, parsec >=2.1.0.1 && <3.2, + build-depends: Cabal >=1.6.0.1 && <1.20, base >= 4.0.0.0 && <4.8, binary >=0.5.0.0 && <0.8, + binary-shared >=0.8 && <0.9, bytestring >=0.9.0.1 && <0.11, + containers >=0.2.0.0 && <0.6, executable-path >=0.0.3 && <0.1, + directory >=1.0.0.2 && <1.3, filepath >=1.1.0.1 && <1.4, ghc >=6.10.1 && <7.9, + ltk >=0.13.1.0 && <0.14, 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.4, strict >=0.3.2 && <0.4 - - if (impl(ghc >= 7.2)) - binary-shared >=0.8.2 - - if (impl(ghc >= 7.4)) - build-depends: haddock >= 2.7.2 && <2.11 + hslogger >= 1.0.7 && <1.3, network >=2.2 && <3.0, conduit >= 1.0.8 && <1.1, + attoparsec-conduit >=1.0.1.2 && <1.1, attoparsec >=0.10.0.3 && <0.12, + transformers >=0.2.2.0 && <0.4, strict >=0.3.2 && <0.4, text >=0.11.3.1 && <1.2 + if (impl(ghc >= 7.8)) + build-depends: haddock >= 2.7.2 && <2.15 else - if (impl(ghc >= 7.2)) - build-depends: haddock >= 2.7.2 && <2.10 + if (impl(ghc >= 7.6)) + build-depends: haddock >= 2.7.2 && <2.14 + else + if (impl(ghc >= 7.4.2)) + build-depends: haddock >= 2.11.1 && <2.12 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.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 + build-depends: process >= 1.1 && <1.3 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 pango-1.0 glib-2.0 + build-depends: Win32 >=2.2.0.0 && <2.4 + extra-libraries: kernel32 pango-1.0 glib-2.0 else - build-depends: unix >=2.3.1.0 && <2.6 + build-depends: unix >=2.3.1.0 && <2.8 if flag(curl) || os(osx) cpp-options: -DUSE_CURL @@ -89,47 +94,59 @@ IDE.Metainfo.SourceCollectorH IDE.Metainfo.SourceDB Paths_leksah_server if (impl(ghc >= 6.12)) - ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans + ghc-options: -O2 -Wall -fno-warn-unused-do-bind -ferror-spans else - ghc-options: -Wall -ferror-spans + ghc-options: -O2 -Wall -ferror-spans 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.1.0 && <0.13, parsec >=2.1.0.1 && <3.2, + build-depends: Cabal >=1.6.0.1 && <1.19, base >= 4.0.0.0 && <4.8, binary >=0.5.0.0 && <0.8, + binary-shared >=0.8 && <0.9, bytestring >=0.9.0.1 && <0.11, + containers >=0.2.0.0 && <0.6, executable-path >=0.0.3 && <0.1, + directory >=1.0.0.2 && <1.3, filepath >=1.1.0.1 && <1.6, ghc >=6.10.1 && <7.9, + ltk >=0.13.1.0 && <0.14, 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.4, strict >=0.3.2 && <0.4 - if (impl(ghc >= 7.4)) - build-depends: haddock >= 2.7.2 && <2.11 + hslogger >= 1.0.7 && <1.3, network >=2.2 && <3.0, conduit >= 1.0.8 && <1.1, + attoparsec-conduit >=1.0.1.2 && <1.1, attoparsec >=0.10.0.3 && <0.12, + transformers >=0.2.2.0 && <0.4, strict >=0.3.2 && <0.4, text >=0.11.3.1 && <1.2 + if (impl(ghc >= 7.8)) + build-depends: haddock >= 2.7.2 && <2.15 else - if (impl(ghc >= 7.2)) - build-depends: haddock >= 2.7.2 && <2.10 + if (impl(ghc >= 7.6)) + build-depends: haddock >= 2.7.2 && <2.14 + else + if (impl(ghc >= 7.4.2)) + build-depends: haddock >= 2.11.1 && <2.12 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.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 + build-depends: process >= 1.1 && <1.3 else build-depends: process-leksah >=1.0.1.3 && <1.1 if os(windows) - build-depends: Win32 >=2.2.0.0 && <2.3 + build-depends: Win32 >=2.2.0.0 && <2.4 extra-libraries: kernel32 pango-1.0 glib-2.0 else - build-depends: unix >=2.3.1.0 && <2.6 + build-depends: unix >=2.3.1.0 && <2.8 + if os(osx) + ghc-options: -optl-headerpad_max_install_names + if flag(curl) || os(osx) cpp-options: -DUSE_CURL @@ -154,9 +171,9 @@ ghc-options: -rtsopts if impl(ghc >= 6.12) - ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans + ghc-options: -O2 -Wall -fno-warn-unused-do-bind -ferror-spans else - ghc-options: -Wall -ferror-spans + ghc-options: -O2 -Wall -ferror-spans ghc-prof-options: -auto-all -prof executable leksahecho @@ -167,13 +184,13 @@ 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.4 + build-depends: base >= 4.0.0.0 && <4.8, hslogger >= 1.0.7 && <1.3, deepseq >=1.1 && <1.4, + bytestring >=0.9.0.1 && <0.11, conduit >= 1.0.8 && <1.1, + attoparsec-conduit >=1.0.1.2 && <1.1, attoparsec >=0.10.0.3 && <0.12, + transformers >=0.2.2.0 && <0.4, text >=0.11.3.1 && <1.2 if (impl(ghc >= 7.2)) - build-depends: process >= 1.1 && <1.2 + build-depends: process >= 1.1 && <1.3 else build-depends: process-leksah >=1.0.1.3 && <1.1 @@ -190,12 +207,12 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: TestTool.hs - build-depends: base >= 4.0.0.0 && <4.6, hslogger >= 1.0.7 && <1.3, - leksah-server, - HUnit >=1.2 && <1.3, transformers >=0.2.2.0 && <0.4, enumerator >=0.4.14 && <0.5 + build-depends: base >= 4.0.0.0 && <4.8, hslogger >= 1.0.7 && <1.3, + leksah-server == 0.13.1.0, + HUnit >=1.2 && <1.3, transformers >=0.2.2.0 && <0.4, conduit >= 1.0.8 && <1.1 if (impl(ghc >= 7.2)) - build-depends: process >= 1.1 && <1.2 + build-depends: process >= 1.1 && <1.3 else build-depends: process-leksah >=1.0.1.3 && <1.1 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 @@ -90,7 +90,7 @@ -- leksahVersion, configDirName :: String -leksahVersion = "0.12" +leksahVersion = "0.13" configDirName = ".leksah-" ++ leksahVersion metadataVersion :: Integer @@ -536,13 +536,17 @@ `seq` rnf (sdComment pd) `seq` rnf (sdExported pd) +#if !MIN_VERSION_ghc(7,7,0) instance NFData PackageIdentifier where rnf pd = rnf (pkgName pd) `seq` rnf (pkgVersion pd) +#endif instance NFData DescrType where rnf a = seq a () +#if !MIN_VERSION_bytestring(0,10,0) instance NFData BS.ByteString where rnf b = seq b () +#endif #if !MIN_VERSION_deepseq(1,3,0) instance NFData Version where rnf v = seq v () @@ -555,8 +559,9 @@ instance NFData ModuleName where rnf = rnf . components +#if !MIN_VERSION_ghc(7,7,0) instance NFData PackageName where rnf (PackageName s) = rnf s - +#endif diff --git a/src/IDE/Core/Serializable.hs b/src/IDE/Core/Serializable.hs --- a/src/IDE/Core/Serializable.hs +++ b/src/IDE/Core/Serializable.hs @@ -31,13 +31,14 @@ import Distribution.Package (PackageName(..),PackageIdentifier(..)) import Data.Version (Version(..)) import Distribution.ModuleName (ModuleName) -import MyMissing (forceJust) import IDE.Core.CTypes +#if !MIN_VERSION_ghc(7,7,0) deriving instance Typeable PackageIdentifier deriving instance Typeable ModuleName deriving instance Typeable PackageName +#endif ----------------------------------------------------------- instance BinaryShared PackModule where @@ -234,7 +235,7 @@ instance BinaryShared ModuleName where put = put . display - get = liftM (flip forceJust "BinaryShared>>get(ModuleName)" . simpleParse) get + get = liftM (fromJust . simpleParse) get instance BinaryShared PackageName where put (PackageName pn) = put pn diff --git a/src/IDE/HeaderParser.hs b/src/IDE/HeaderParser.hs --- a/src/IDE/HeaderParser.hs +++ b/src/IDE/HeaderParser.hs @@ -18,20 +18,36 @@ ) where +import Prelude hiding (readFile) import IDE.Core.CTypes hiding(SrcSpan(..)) import GHC hiding (ImportDecl) import FastString(unpackFS) -import RdrName(showRdrName) import IDE.Utils.GHCUtils import Data.Maybe (mapMaybe) #if MIN_VERSION_ghc(7,4,1) -import Outputable(pprPrefixOcc,showSDoc) +import Outputable(pprPrefixOcc, ppr) #else -import Outputable(pprHsVar,showSDoc) +import Outputable(pprHsVar, ppr) #endif +#if MIN_VERSION_ghc(7,6,0) +import Outputable(showSDoc) +#else +import qualified Outputable as O +#endif import IDE.Utils.FileUtils (figureOutHaddockOpts) import Control.Monad.IO.Class (MonadIO(..)) +import System.IO.Strict (readFile) +#if !MIN_VERSION_ghc(7,6,0) +showSDoc :: DynFlags -> O.SDoc -> String +showSDoc _ = O.showSDoc +showSDocUnqual :: DynFlags -> O.SDoc -> String +showSDocUnqual _ = O.showSDocUnqual +#endif + +showRdrName :: DynFlags -> RdrName -> String +showRdrName dflags r = showSDoc dflags (ppr r) + parseTheHeader :: FilePath -> IO ServerAnswer parseTheHeader filePath = do text <- readFile filePath @@ -39,7 +55,7 @@ parseResult <- liftIO $ myParseHeader filePath text opts case parseResult of Left str -> return (ServerFailed str) - Right (pr@HsModule{ hsmodImports = []}) -> do + 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 [] -> case hsmodExports pr of @@ -48,13 +64,13 @@ Nothing -> 0 Just mn -> srcSpanEndLine' (getLoc mn) + 2 return (ServerHeader (Right i)) - Right (_pr@HsModule{ hsmodImports = imports }) -> return (ServerHeader (Left (transformImports imports))) + Right (dflags, _pr@HsModule{ hsmodImports = imports }) -> return (ServerHeader (Left (transformImports dflags imports))) -transformImports :: [LImportDecl RdrName] -> [ImportDecl] -transformImports = map transformImport +transformImports :: DynFlags -> [LImportDecl RdrName] -> [ImportDecl] +transformImports dflags = map (transformImport dflags) -transformImport :: LImportDecl RdrName -> ImportDecl -transformImport (L srcSpan importDecl) = +transformImport :: DynFlags -> LImportDecl RdrName -> ImportDecl +transformImport dflags (L srcSpan importDecl) = ImportDecl { importLoc = srcSpanToLocation srcSpan, importModule = modName, @@ -73,19 +89,19 @@ Just mn -> Just (moduleNameString mn) specs = case ideclHiding importDecl of Nothing -> Nothing - Just (hide, list) -> Just (ImportSpecList hide (mapMaybe transformEntity list)) + Just (hide, list) -> Just (ImportSpecList hide (mapMaybe (transformEntity dflags) list)) -transformEntity :: LIE RdrName -> Maybe ImportSpec +transformEntity :: DynFlags -> LIE RdrName -> Maybe ImportSpec #if MIN_VERSION_ghc(7,2,0) -transformEntity (L _ (IEVar name)) = Just (IVar (showSDoc (pprPrefixOcc name))) +transformEntity dflags (L _ (IEVar name)) = Just (IVar (showSDoc dflags (pprPrefixOcc name))) #else -transformEntity (L _ (IEVar name)) = Just (IVar (showSDoc (pprHsVar name))) +transformEntity dflags (L _ (IEVar name)) = Just (IVar (showSDoc dflags (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 +transformEntity dflags (L _ (IEThingAbs name)) = Just (IAbs (showRdrName dflags name)) +transformEntity dflags (L _ (IEThingAll name)) = Just (IThingAll (showRdrName dflags name)) +transformEntity dflags (L _ (IEThingWith name list)) = Just (IThingWith (showRdrName dflags name) + (map (showRdrName dflags) list)) +transformEntity _ _ = Nothing #if MIN_VERSION_ghc(7,2,0) srcSpanToLocation :: SrcSpan -> Location 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 @@ -23,7 +23,6 @@ import System.Environment (getArgs) import Control.Monad (when) import Data.Version (showVersion) -import Paths_leksah_server (getDataDir, version) import IDE.Utils.FileUtils import IDE.Utils.Utils import IDE.Utils.GHCUtils @@ -34,7 +33,7 @@ import Control.Monad (liftM) import qualified Data.Set as Set (member) import IDE.Core.CTypes hiding (Extension) -import IDE.Metainfo.SourceDB (buildSourceForPackageDB) +import IDE.Metainfo.SourceDB (buildSourceForPackageDB, getDataDir, version) import Data.Time import Control.Exception (catch, SomeException) 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,6 +23,7 @@ import Module hiding (PackageId,ModuleName) import qualified Module as Module (ModuleName) import qualified Maybes as M +import DynFlags (DynFlags) #if MIN_VERSION_ghc(7,2,0) import HscTypes import GhcMonad hiding (liftIO) @@ -36,7 +37,12 @@ import TysWiredIn ( eqTyConName ) #endif import LoadIface +#if MIN_VERSION_ghc(7,6,0) import Outputable hiding(trace) +#else +import Outputable hiding(trace, showSDoc, showSDocUnqual) +import qualified Outputable as O +#endif import IfaceSyn import FastString import Name @@ -65,15 +71,21 @@ import IDE.Utils.GHCUtils import Control.DeepSeq(deepseq) +#if !MIN_VERSION_ghc(7,6,0) +showSDoc :: DynFlags -> SDoc -> String +showSDoc _ = O.showSDoc +showSDocUnqual :: DynFlags -> SDoc -> String +showSDocUnqual _ = O.showSDocUnqual +#endif collectPackageFromHI :: PackageConfig -> IO PackageDescr -collectPackageFromHI packageConfig = inGhcIO [] [] $ \ _ -> do +collectPackageFromHI packageConfig = inGhcIO [] [] $ \ dflags -> do session <- getSession exportedIfaceInfos <- getIFaceInfos (getThisPackage packageConfig) (IPI.exposedModules packageConfig) session hiddenIfaceInfos <- getIFaceInfos (getThisPackage packageConfig) (IPI.hiddenModules packageConfig) session - let pd = extractInfo exportedIfaceInfos hiddenIfaceInfos (getThisPackage packageConfig) + let pd = extractInfo dflags exportedIfaceInfos hiddenIfaceInfos (getThisPackage packageConfig) #if MIN_VERSION_Cabal(1,8,0) [] -- TODO 6.12 (IPI.depends $ packageConfigToInstalledPackageInfo packageConfig)) #else @@ -101,20 +113,20 @@ ------------------------------------------------------------------------- -extractInfo :: [(ModIface, FilePath)] -> [(ModIface, FilePath)] -> PackageIdentifier -> +extractInfo :: DynFlags -> [(ModIface, FilePath)] -> [(ModIface, FilePath)] -> PackageIdentifier -> [PackageIdentifier] -> PackageDescr -extractInfo ifacesExp ifacesHid pid buildDepends = - let allDescrs = concatMap (extractExportedDescrH pid) +extractInfo dflags ifacesExp ifacesHid pid buildDepends = + let allDescrs = concatMap (extractExportedDescrH dflags pid) (map fst (ifacesHid ++ ifacesExp)) - mods = map (extractExportedDescrR pid allDescrs) (map fst ifacesExp) + mods = map (extractExportedDescrR dflags pid allDescrs) (map fst ifacesExp) in PackageDescr { pdPackage = pid , pdModules = mods , pdBuildDepends = buildDepends , pdMbSourcePath = Nothing} -extractExportedDescrH :: PackageIdentifier -> ModIface -> [Descr] -extractExportedDescrH pid iface = +extractExportedDescrH :: DynFlags -> PackageIdentifier -> ModIface -> [Descr] +extractExportedDescrH dflags pid iface = let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface) exportedNames = Set.fromList #if MIN_VERSION_Cabal(1,11,0) @@ -129,14 +141,15 @@ exportedDecls = filter (\ ifdecl -> (occNameString $ ifName ifdecl) `Set.member` exportedNames) (map snd (mi_decls iface)) - in concatMap (extractIdentifierDescr pid [mid]) exportedDecls + in concatMap (extractIdentifierDescr dflags pid [mid]) exportedDecls -extractExportedDescrR :: PackageIdentifier +extractExportedDescrR :: DynFlags + -> PackageIdentifier -> [Descr] -> ModIface -> ModuleDescr -extractExportedDescrR pid hidden iface = +extractExportedDescrR dflags pid hidden iface = let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface) exportedNames = Set.fromList #if MIN_VERSION_Cabal(1,11,0) @@ -151,12 +164,12 @@ exportedDecls = filter (\ ifdecl -> (occNameString $ifName ifdecl) `Set.member` exportedNames) (map snd (mi_decls iface)) - ownDecls = concatMap (extractIdentifierDescr pid [mid]) exportedDecls + ownDecls = concatMap (extractIdentifierDescr dflags pid [mid]) exportedDecls otherDecls = exportedNames `Set.difference` (Set.fromList (map dscName ownDecls)) reexported = map (\d -> Reexported (ReexportedDescr (Just (PM pid mid)) d)) $ filter (\k -> (dscName k) `Set.member` otherDecls) hidden - inst = concatMap (extractInstances (PM pid mid)) (mi_insts iface) - uses = Map.fromList . catMaybes $ map extractUsages (mi_usages iface) + inst = concatMap (extractInstances dflags (PM pid mid)) (mi_insts iface) + uses = Map.fromList . catMaybes $ map (extractUsages dflags) (mi_usages iface) declsWithExp = map withExp ownDecls withExp (Real d) = Real $ d{dscExported' = Set.member (dscName' d) exportedNames} withExp _ = error "Unexpected Reexported" @@ -166,14 +179,14 @@ , mdReferences = uses , mdIdDescriptions = declsWithExp ++ inst ++ reexported} -extractIdentifierDescr :: PackageIdentifier -> [ModuleName] -> IfaceDecl -> [Descr] -extractIdentifierDescr package modules decl +extractIdentifierDescr :: DynFlags -> PackageIdentifier -> [ModuleName] -> IfaceDecl -> [Descr] +extractIdentifierDescr dflags package modules decl = if null modules then [] else let descr = RealDescr{ dscName' = unpackFS $occNameFS (ifName decl) - , dscMbTypeStr' = Just (BS.pack $ unlines $ nonEmptyLines $ filterExtras $ showSDocUnqual $ppr decl) + , dscMbTypeStr' = Just (BS.pack $ unlines $ nonEmptyLines $ filterExtras $ showSDocUnqual dflags $ppr decl) , dscMbModu' = Just (PM package (last modules)) , dscMbLocation' = Nothing , dscMbComment' = Nothing @@ -188,20 +201,20 @@ #endif -> map Real [descr] #if MIN_VERSION_Cabal(1,11,0) - (IfaceData name _ _ ifCons' _ _ _) + (IfaceData {ifName=name, ifCons=ifCons'}) #else (IfaceData name _ _ ifCons' _ _ _ _) #endif -> let d = case ifCons' of IfDataTyCon _decls -> let - fieldNames = concatMap extractFields (visibleIfConDecls ifCons') - constructors' = extractConstructors name (visibleIfConDecls ifCons') + fieldNames = concatMap (extractFields dflags) (visibleIfConDecls ifCons') + constructors' = extractConstructors dflags name (visibleIfConDecls ifCons') in DataDescr constructors' fieldNames IfNewTyCon _ -> let - fieldNames = concatMap extractFields (visibleIfConDecls ifCons') - constructors' = extractConstructors name (visibleIfConDecls ifCons') + fieldNames = concatMap (extractFields dflags) (visibleIfConDecls ifCons') + constructors' = extractConstructors dflags name (visibleIfConDecls ifCons') mbField = case fieldNames of [] -> Nothing [fn] -> Just fn @@ -217,21 +230,33 @@ #else IfAbstractTyCon -> DataDescr [] [] #endif +#if MIN_VERSION_ghc(7,6,0) + IfDataFamTyCon -> DataDescr [] [] +#else IfOpenDataTyCon -> DataDescr [] [] +#endif in [Real (descr{dscTypeHint' = d})] +#if MIN_VERSION_ghc(7,6,0) + (IfaceClass {ifCtxt = context, ifSigs = ifSigs'} ) +#else (IfaceClass context _ _ _ _ ifSigs' _ ) +#endif -> let - classOpsID = map extractClassOp ifSigs' + classOpsID = map (extractClassOp dflags) ifSigs' superclasses = extractSuperClassNames context in [Real $ descr{dscTypeHint' = ClassDescr superclasses classOpsID}] - (IfaceSyn _ _ _ _ _ ) + (IfaceSyn {}) -> [Real $ descr{dscTypeHint' = TypeDescr}] - (IfaceForeign _ _) +#if MIN_VERSION_ghc(7,6,0) + (IfaceAxiom {}) -> [Real $ descr] +#endif + (IfaceForeign {}) + -> [Real $ descr] -extractConstructors :: OccName -> [IfaceConDecl] -> [SimpleDescr] -extractConstructors name decls = map (\decl -> SimpleDescr (unpackFS $occNameFS (ifConOcc decl)) - (Just (BS.pack $ filterExtras $ showSDocUnqual $ +extractConstructors :: DynFlags -> OccName -> [IfaceConDecl] -> [SimpleDescr] +extractConstructors dflags name decls = map (\decl -> SimpleDescr (unpackFS $occNameFS (ifConOcc decl)) + (Just (BS.pack $ filterExtras $ showSDocUnqual dflags $ pprIfaceForAllPart (ifConUnivTvs decl ++ ifConExTvs decl) (eq_ctxt decl ++ ifConCtxt decl) (pp_tau decl))) Nothing Nothing True) decls @@ -248,20 +273,20 @@ #endif | (tv,ty) <- ifConEqSpec decl] -extractFields :: IfaceConDecl -> [SimpleDescr] -extractFields decl = map (\ (n, t) -> SimpleDescr n t Nothing Nothing True) +extractFields :: DynFlags -> IfaceConDecl -> [SimpleDescr] +extractFields dflags decl = map (\ (n, t) -> SimpleDescr n t Nothing Nothing True) $ zip (map extractFieldNames (ifConFields decl)) - (map extractType (ifConArgTys decl)) + (map (extractType dflags) (ifConArgTys decl)) -extractType :: IfaceType -> Maybe ByteString -extractType it = Just ((BS.pack . filterExtras . showSDocUnqual . ppr) it) +extractType :: DynFlags -> IfaceType -> Maybe ByteString +extractType dflags it = Just ((BS.pack . filterExtras . showSDocUnqual dflags . ppr) it) extractFieldNames :: OccName -> String extractFieldNames occName = unpackFS $occNameFS occName -extractClassOp :: IfaceClassOp -> SimpleDescr -extractClassOp (IfaceClassOp occName _dm ty) = SimpleDescr (unpackFS $occNameFS occName) - (Just (BS.pack $ showSDocUnqual (ppr ty))) +extractClassOp :: DynFlags -> IfaceClassOp -> SimpleDescr +extractClassOp dflags (IfaceClassOp occName _dm ty) = SimpleDescr (unpackFS $occNameFS occName) + (Just (BS.pack $ showSDocUnqual dflags (ppr ty))) Nothing Nothing True extractSuperClassNames :: [IfacePredType] -> [String] @@ -273,10 +298,17 @@ #endif extractSuperClassName _ = Nothing -extractInstances :: PackModule -> IfaceInst -> [Descr] -extractInstances pm ifaceInst = - let className = showSDocUnqual $ ppr $ ifInstCls ifaceInst - dataNames = map (\iftc -> showSDocUnqual $ ppr iftc) +extractInstances :: DynFlags + -> PackModule +#if MIN_VERSION_ghc(7,6,0) + -> IfaceClsInst +#else + -> IfaceInst +#endif + -> [Descr] +extractInstances dflags pm ifaceInst = + let className = showSDocUnqual dflags $ ppr $ ifInstCls ifaceInst + dataNames = map (\iftc -> showSDocUnqual dflags $ ppr iftc) $ map fromJust $ filter isJust $ ifInstTys ifaceInst @@ -290,24 +322,24 @@ , dscExported' = False})] -extractUsages :: Usage -> Maybe (ModuleName, Set String) +extractUsages :: DynFlags -> Usage -> Maybe (ModuleName, Set String) #if MIN_VERSION_Cabal(1,11,0) -extractUsages (UsagePackageModule usg_mod' _ _) = +extractUsages _ (UsagePackageModule usg_mod' _ _) = #else -extractUsages (UsagePackageModule usg_mod' _ ) = +extractUsages _ (UsagePackageModule usg_mod' _ ) = #endif let name = (fromJust . simpleParse . moduleNameString) (moduleName usg_mod') in Just (name, Set.fromList []) #if MIN_VERSION_Cabal(1,11,0) -extractUsages (UsageHomeModule usg_mod_name' _ usg_entities' _ _) = +extractUsages dflags (UsageHomeModule usg_mod_name' _ usg_entities' _ _) = #else -extractUsages (UsageHomeModule usg_mod_name' _ usg_entities' _) = +extractUsages dflags (UsageHomeModule usg_mod_name' _ usg_entities' _) = #endif let name = (fromJust . simpleParse . moduleNameString) usg_mod_name' - ids = map (showSDocUnqual . ppr . fst) usg_entities' + ids = map (showSDocUnqual dflags . ppr . fst) usg_entities' in Just (name, Set.fromList ids) #if MIN_VERSION_ghc(7,4,0) -extractUsages (UsageFile _ _) = Nothing +extractUsages _ (UsageFile _ _) = Nothing #endif filterExtras, filterExtras' :: String -> String 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 @@ -55,9 +55,8 @@ import System.Process (system) #endif #endif -import Prelude hiding(catch) import Control.Monad.IO.Class (MonadIO, MonadIO(..)) -import qualified Control.Exception as NewException (SomeException, catch) +import qualified Control.Exception as E (SomeException, catch) import IDE.Utils.Tool (runTool') collectPackage :: Bool -> Prefs -> Int -> (PackageConfig,Int) -> IO PackageCollectStats @@ -132,15 +131,15 @@ filePath = collectorPath packString <.> leksahMetadataSystemFileExtension debugM "leksah-server" $ "collectPackage: before retreiving = " ++ fullUrl #if defined(USE_LIBCURL) - catch (do + E.catch (do (code, string) <- curlGetString_ fullUrl [] when (code == CurlOK) $ withBinaryFile filePath WriteMode $ \ file -> do hPutStr file string) #elif defined(USE_CURL) - catch ((system $ "curl -OL --fail " ++ fullUrl) >> return ()) + E.catch ((system $ "curl -OL --fail " ++ fullUrl) >> return ()) #else - catch ((system $ "wget " ++ fullUrl) >> return ()) + E.catch ((system $ "wget " ++ fullUrl) >> return ()) #endif (\(e :: SomeException) -> debugM "leksah-server" $ "collectPackage: Error when calling wget " ++ show e) @@ -154,8 +153,8 @@ runCabalConfigure fpSource = do let dirPath = dropFileName fpSource setCurrentDirectory dirPath - NewException.catch (runTool' "cabal" (["configure","--user"]) Nothing >> return ()) - (\ (_e :: NewException.SomeException) -> do + E.catch (runTool' "cabal" (["configure","--user"]) Nothing >> return ()) + (\ (_e :: E.SomeException) -> do debugM "leksah-server" "Can't configure" return ()) 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 @@ -35,7 +35,11 @@ import Documentation.Haddock #endif import Distribution.Text (simpleParse) +#if MIN_VERSION_ghc(7,6,0) +import InstEnv (ClsInst(..)) +#else import InstEnv (Instance(..)) +#endif import MyMissing import Data.Map (Map) import qualified Data.Map as Map (empty) @@ -70,8 +74,14 @@ import System.Log.Logger (warningM, debugM) import Control.DeepSeq (deepseq) import Data.ByteString.Char8 (ByteString) -import Outputable hiding (trace) +#if MIN_VERSION_ghc(7,6,0) +import Outputable hiding(trace) +#else +import Outputable hiding(trace, showSDoc, showSDocUnqual) +import qualified Outputable as O +#endif import GHC.Show(showSpace) +import Name #ifdef MIN_VERSION_haddock_leksah #else @@ -84,15 +94,22 @@ isEmptyDoc DocEmpty = True isEmptyDoc _ = False -show' :: Outputable alpha => alpha -> String #if MIN_VERSION_ghc(6,12,1) type MyLDocDecl = LDocDecl -show' = showSDoc . ppr #else type MyLDocDecl = LDocDecl Name -show' = showSDoc . ppr #endif +#if !MIN_VERSION_ghc(7,6,0) +showSDoc :: DynFlags -> SDoc -> String +showSDoc _ = O.showSDoc +showSDocUnqual :: DynFlags -> SDoc -> String +showSDocUnqual _ = O.showSDocUnqual +#endif + +show' :: Outputable alpha => DynFlags -> alpha -> String +show' dflags = showSDoc dflags . ppr + data PackageCollectStats = PackageCollectStats { packageString :: String, modulesTotal :: Maybe Int, @@ -136,14 +153,14 @@ warningM "leksah-server" ("Ghc failed to process: " ++ show e) return (Nothing, PackageCollectStats packageName Nothing False False (Just ("Ghc failed to process: " ++ show e))) - inner ghcFlags = inGhcIO ghcFlags [Opt_Haddock] $ \ _flags -> do + inner ghcFlags = inGhcIO ghcFlags [Opt_Haddock] $ \ dflags -> do #if MIN_VERSION_haddock(2,8,0) (interfaces,_) <- processModules verbose (exportedMods ++ hiddenMods) [] [] #else (interfaces,_) <- createInterfaces verbose (exportedMods ++ hiddenMods) [] [] #endif liftIO $ print (length interfaces) - let mods = map (interfaceToModuleDescr dirPath (getThisPackage packageConfig)) interfaces + let mods = map (interfaceToModuleDescr dflags dirPath (getThisPackage packageConfig)) interfaces sp <- liftIO $ myCanonicalizePath dirPath let pd = PackageDescr { pdPackage = getThisPackage packageConfig @@ -159,8 +176,8 @@ -- Heaven -interfaceToModuleDescr :: FilePath -> PackageIdentifier -> Interface -> ModuleDescr -interfaceToModuleDescr _dirPath pid interface = +interfaceToModuleDescr :: DynFlags -> FilePath -> PackageIdentifier -> Interface -> ModuleDescr +interfaceToModuleDescr dflags _dirPath pid interface = ModuleDescr { mdModuleId = PM pid modName , mdMbSourcePath = Just filepath @@ -170,30 +187,42 @@ filepath = ifaceOrigFilename interface modName = forceJust ((simpleParse . moduleNameString . moduleName . ifaceMod) interface) "Can't parse module name" - descrs = extractDescrs (PM pid modName) + descrs = extractDescrs dflags (PM pid modName) (ifaceDeclMap interface) (ifaceExportItems interface) (ifaceInstances interface) [] --(ifaceLocals interface) imports = Map.empty --TODO +#if MIN_VERSION_haddock(2,11,0) +getDoc :: Documentation Name -> Maybe NDoc +getDoc = documentationDoc +#else +getDoc :: Maybe NDoc -> Maybe NDoc +getDoc = id +#endif + #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 = - transformToDescrs pm exportedDeclInfo ++ map (toDescrInst pm) ifaceInstances' +#if MIN_VERSION_ghc(7,6,0) +extractDescrs :: DynFlags -> PackModule -> Map Name DeclInfo -> [ExportItem Name] -> [ClsInst] -> [Name] -> [Descr] +#else +extractDescrs :: DynFlags -> PackModule -> Map Name DeclInfo -> [ExportItem Name] -> [Instance] -> [Name] -> [Descr] +#endif +extractDescrs dflags pm _ifaceDeclMap ifaceExportItems' ifaceInstances' _ifaceLocals = + transformToDescrs dflags pm exportedDeclInfo ++ map (toDescrInst dflags pm) ifaceInstances' where exportedDeclInfo = mapMaybe toDeclInfo ifaceExportItems' toDeclInfo (ExportDecl decl mbDoc subDocs _) = - Just(decl,fst mbDoc,map (\ (a,b) -> (a,fst b)) subDocs) + Just(decl,getDoc $ fst mbDoc,map (\ (a,b) -> (a,getDoc $ fst b)) subDocs) toDeclInfo (ExportNoDecl _ _) = Nothing toDeclInfo (ExportGroup _ _ _) = Nothing toDeclInfo (ExportDoc _) = Nothing toDeclInfo (ExportModule _) = Nothing #else -extractDescrs :: PackModule -> Map Name DeclInfo -> [ExportItem Name] -> [Instance] -> [Name] -> [Descr] -extractDescrs pm _ifaceDeclMap ifaceExportItems' ifaceInstances' _ifaceLocals = - transformToDescrs pm exportedDeclInfo ++ map (toDescrInst pm) ifaceInstances' +extractDescrs :: DynFlags -> PackModule -> Map Name DeclInfo -> [ExportItem Name] -> [Instance] -> [Name] -> [Descr] +extractDescrs dflags pm _ifaceDeclMap ifaceExportItems' ifaceInstances' _ifaceLocals = + transformToDescrs dflags pm exportedDeclInfo ++ map (toDescrInst dflags pm) ifaceInstances' where exportedDeclInfo = mapMaybe toDeclInfo ifaceExportItems' toDeclInfo (ExportDecl decl mbDoc subDocs _) = Just(decl,mbDoc,subDocs) @@ -203,8 +232,8 @@ toDeclInfo (ExportModule _) = Nothing #endif -transformToDescrs :: PackModule -> [(LHsDecl Name, Maybe NDoc, [(Name, Maybe NDoc)])] -> [Descr] -transformToDescrs pm = concatMap transformToDescr +transformToDescrs :: DynFlags -> PackModule -> [(LHsDecl Name, Maybe NDoc, [(Name, Maybe NDoc)])] -> [Descr] +transformToDescrs dflags pm = concatMap transformToDescr where #if MIN_VERSION_ghc(7,2,0) transformToDescr ((L loc (SigD (TypeSig [name] typ))), mbComment,_subCommentList) = @@ -213,136 +242,182 @@ #endif [Real $ RealDescr { dscName' = getOccString (unLoc name) - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr typ)) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc - , dscMbComment' = toComment mbComment [] + , dscMbComment' = toComment dflags mbComment [] , dscTypeHint' = VariableDescr , dscExported' = True}] transformToDescr ((L _loc (SigD _)), _mbComment, _subCommentList) = [] + +#if MIN_VERSION_ghc(7,6,0) + transformToDescr ((L loc (TyClD typ@(ForeignType {tcdLName = lid}))), mbComment,_sigList) = + [Real $ RealDescr { + dscName' = getOccString (unLoc lid) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) + , dscMbModu' = Just pm + , dscMbLocation' = srcSpanToLocation loc + , dscMbComment' = toComment dflags mbComment [] + , dscTypeHint' = TypeDescr + , dscExported' = True}] + +#if MIN_VERSION_ghc(7,7,0) + transformToDescr ((L loc (TyClD typ@(FamDecl {tcdFam = (FamilyDecl {fdLName = lid})}))), mbComment,_sigList) = +#else + transformToDescr ((L loc (TyClD typ@(TyFamily {tcdLName = lid}))), mbComment,_sigList) = +#endif + [Real $ RealDescr { + dscName' = getOccString (unLoc lid) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) + , dscMbModu' = Just pm + , dscMbLocation' = srcSpanToLocation loc + , dscMbComment' = toComment dflags mbComment [] + , dscTypeHint' = TypeDescr + , dscExported' = True}] +#endif + +#if MIN_VERSION_ghc(7,7,0) + transformToDescr ((L loc (TyClD typ@(SynDecl {tcdLName = lid}))), mbComment,_sigList) = +#elif MIN_VERSION_ghc(7,6,0) + transformToDescr ((L loc (TyClD typ@(TyDecl {tcdLName = lid, tcdTyDefn = TySynonym {}}))), mbComment,_sigList) = +#else transformToDescr ((L loc (TyClD typ@(TySynonym lid _ _ _ ))), mbComment, _subCommentList) = +#endif [Real $ RealDescr { dscName' = getOccString (unLoc lid) - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr typ)) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc - , dscMbComment' = toComment mbComment [] + , dscMbComment' = toComment dflags mbComment [] , dscTypeHint' = TypeDescr , dscExported' = True}] - transformToDescr ((L loc (TyClD typ@(TyData DataType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_subCommentList) = +#if MIN_VERSION_ghc(7,7,0) + transformToDescr ((L loc (TyClD typ@(DataDecl {tcdLName = lid, tcdDataDefn = HsDataDefn {dd_cons=lConDecl, dd_derivs=tcdDerivs'}}))), mbComment,_sigList) = +#elif MIN_VERSION_ghc(7,6,0) + transformToDescr ((L loc (TyClD typ@(TyDecl {tcdLName = lid, tcdTyDefn = TyData {td_cons=lConDecl, td_derivs=tcdDerivs'}}))), mbComment,_sigList) = +#else + transformToDescr ((L loc (TyClD typ@(TyData DataType _ lid _ _ _ lConDecl tcdDerivs'))), mbComment,_subCommentList) = +#endif [Real $ RealDescr { dscName' = name - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr (uncommentData typ))) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc - , dscMbComment' = toComment mbComment [] + , dscMbComment' = toComment dflags mbComment [] , dscTypeHint' = DataDescr constructors fields , dscExported' = True}] ++ derivings tcdDerivs' where - constructors = map extractConstructor lConDecl - fields = nub $ concatMap extractRecordFields lConDecl - name = getOccString (unLoc tcdLName') + constructors = map (extractConstructor dflags) lConDecl + fields = nub $ concatMap (extractRecordFields dflags) lConDecl + name = getOccString (unLoc lid) derivings Nothing = [] derivings (Just _l) = [] +#if !MIN_VERSION_ghc(7,6,0) transformToDescr ((L loc (TyClD typ@(TyData NewType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_subCommentList) = [Real $ RealDescr { dscName' = name - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr (uncommentData typ))) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc - , dscMbComment' = toComment mbComment [] + , dscMbComment' = toComment dflags mbComment [] , dscTypeHint' = NewtypeDescr constructor mbField , dscExported' = True}] ++ derivings tcdDerivs' where - constructor = forceHead (map extractConstructor lConDecl) + constructor = forceHead (map (extractConstructor dflags) lConDecl) "WorkspaceCollector>>transformToDescr: no constructor for newtype" - mbField = case concatMap extractRecordFields lConDecl of + mbField = case concatMap (extractRecordFields dflags) lConDecl of [] -> Nothing a:_ -> Just a name = getOccString (unLoc tcdLName') derivings Nothing = [] derivings (Just _l) = [] +#endif 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})) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr cl{tcdMeths = emptyLHsBinds})) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc - , dscMbComment' = toComment mbComment [] + , dscMbComment' = toComment dflags mbComment [] , dscTypeHint' = ClassDescr super methods , dscExported' = True }] where - methods = extractMethods tcdSigs' docs + methods = extractMethods dflags tcdSigs' docs super = [] transformToDescr (_, _mbComment, _sigList) = [] -toDescrInst :: PackModule -> Instance -> Descr -toDescrInst pm inst@(Instance is_cls' _is_tcs _is_tvs is_tys' _is_dfun _is_flag) = +#if MIN_VERSION_ghc(7,6,0) +toDescrInst :: DynFlags -> PackModule -> ClsInst -> Descr +toDescrInst dflags pm inst@(ClsInst {is_cls = is_cls', is_tys = is_tys'}) = +#else +toDescrInst :: DynFlags -> PackModule -> Instance -> Descr +toDescrInst dflags pm inst@(Instance is_cls' _is_tcs _is_tvs is_tys' _is_dfun _is_flag) = +#endif Real $ RealDescr { dscName' = getOccString is_cls' - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr inst)) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr inst)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation (getSrcSpan inst) , dscMbComment' = Nothing - , dscTypeHint' = InstanceDescr (map (showSDocUnqual . ppr) is_tys') + , dscTypeHint' = InstanceDescr (map (showSDocUnqual dflags . ppr) is_tys') , dscExported' = True} -extractMethods :: [LSig Name] -> [MyLDocDecl] -> [SimpleDescr] -extractMethods sigs docs = - let pairs = attachComments' sigs docs - in mapMaybe extractMethod pairs +extractMethods :: DynFlags -> [LSig Name] -> [MyLDocDecl] -> [SimpleDescr] +extractMethods dflags sigs docs = + let pairs = attachComments' dflags sigs docs + in mapMaybe (extractMethod dflags) pairs -extractMethod :: (LHsDecl Name, Maybe NDoc) -> Maybe SimpleDescr +extractMethod :: DynFlags -> (LHsDecl Name, Maybe NDoc) -> Maybe SimpleDescr #if MIN_VERSION_ghc(7,2,0) -extractMethod ((L loc (SigD ts@(TypeSig [name] _typ))), mbDoc) = +extractMethod dflags ((L loc (SigD ts@(TypeSig [name] _typ))), mbDoc) = #else -extractMethod ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) = +extractMethod dflags ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) = #endif Just $ SimpleDescr (getOccString (unLoc name)) - (Just (BS.pack (showSDocUnqual $ ppr ts))) + (Just (BS.pack (showSDocUnqual dflags $ ppr ts))) (srcSpanToLocation loc) - (toComment mbDoc []) + (toComment dflags mbDoc []) True -extractMethod (_, _mbDoc) = Nothing +extractMethod _dflags (_, _mbDoc) = Nothing -extractConstructor :: LConDecl Name -> SimpleDescr -extractConstructor decl@(L loc (ConDecl {con_name = name, con_doc = doc})) = +extractConstructor :: DynFlags -> LConDecl Name -> SimpleDescr +extractConstructor dflags decl@(L loc (ConDecl {con_name = name, con_doc = doc})) = SimpleDescr (getOccString (unLoc name)) - (Just (BS.pack (showSDocUnqual $ppr (uncommentDecl decl)))) + (Just (BS.pack (showSDocUnqual dflags $ppr (uncommentDecl decl)))) (srcSpanToLocation loc) (case doc of Nothing -> Nothing - Just (L _ d) -> Just (BS.pack (printHsDoc'' d))) + Just (L _ d) -> Just (BS.pack (printHsDoc d))) True -extractRecordFields :: LConDecl Name -> [SimpleDescr] -extractRecordFields (L _ _decl@(ConDecl {con_details=(RecCon flds)})) = +extractRecordFields :: DynFlags -> LConDecl Name -> [SimpleDescr] +extractRecordFields dflags (L _ _decl@(ConDecl {con_details=(RecCon flds)})) = map extractRecordFields' flds where extractRecordFields' _field@(ConDeclField (L loc name) typ doc) = SimpleDescr (getOccString name) - (Just (BS.pack (showSDocUnqual $ ppr typ))) + (Just (BS.pack (showSDocUnqual dflags $ ppr typ))) (srcSpanToLocation loc) (case doc of Nothing -> Nothing - Just (L _ d) -> Just (BS.pack (printHsDoc'' d))) + Just (L _ d) -> Just (BS.pack (printHsDoc d))) True -extractRecordFields _ = [] +extractRecordFields _ _ = [] -toComment :: Maybe NDoc -> [NDoc] -> Maybe ByteString -toComment (Just c) _ = Just (BS.pack (printHsDoc' c)) -toComment Nothing (c:_) = Just (BS.pack (printHsDoc' c)) -toComment Nothing [] = Nothing +toComment :: DynFlags -> Maybe NDoc -> [NDoc] -> Maybe ByteString +toComment dflags (Just c) _ = Just (BS.pack (printHsDoc' dflags c)) +toComment dflags Nothing (c:_) = Just (BS.pack (printHsDoc' dflags c)) +toComment _ Nothing [] = Nothing {-- @@ -353,66 +428,62 @@ = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Class] [] --} -printHsDoc' :: HsDoc Name -> String -printHsDoc' d = show (PPDoc d) - -#if MIN_VERSION_ghc(6,12,1) -printHsDoc'' :: HsDocString -> String -printHsDoc'' = printHsDoc -#else -printHsDoc'' :: HsDoc Name -> String -printHsDoc'' = printHsDoc' -#endif +printHsDoc' :: DynFlags -> HsDoc Name -> String +printHsDoc' dflags d = show (PPDoc dflags d) -newtype PPDoc alpha = PPDoc (HsDoc alpha) +data PPDoc alpha = PPDoc DynFlags (HsDoc alpha) instance Outputable alpha => Show (PPDoc alpha) where - showsPrec _ (PPDoc DocEmpty) = id - showsPrec _ (PPDoc (DocAppend l r)) = shows (PPDoc l) . shows (PPDoc r) - 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] - 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 '@' - showsPrec _ (PPDoc (DocUnorderedList l)) = - foldr (\s r -> showString "* " . shows (PPDoc s) . showChar '\n' . r) id l - showsPrec _ (PPDoc (DocOrderedList l)) = - foldr (\(i,n) _f -> shows n . showSpace . shows (PPDoc i)) id (zip l [1 .. length l]) - showsPrec _ (PPDoc (DocDefList li)) = - foldr (\(l,r) f -> showString "[@" . shows (PPDoc l) . showString "[@ " . shows (PPDoc r) . f) id li - showsPrec _ (PPDoc (DocCodeBlock doc)) = showChar '@' . shows (PPDoc doc) . showChar '@' - showsPrec _ (PPDoc (DocURL str)) = showChar '<' . showString str . showChar '>' - showsPrec _ (PPDoc (DocAName str)) = showChar '#' . showString str . showChar '#' - showsPrec _ (PPDoc _) = id + showsPrec _ (PPDoc _ DocEmpty) = id + showsPrec _ (PPDoc d (DocAppend l r)) = shows (PPDoc d l) . shows (PPDoc d r) + showsPrec _ (PPDoc _ (DocString str)) = showString str + showsPrec _ (PPDoc d (DocParagraph doc)) = shows (PPDoc d doc) . showChar '\n' + showsPrec _ (PPDoc d (DocIdentifier l)) = foldr (\i _f -> showChar '\'' . + ((showString . showSDoc d . ppr) i) . showChar '\'') id [l] + showsPrec _ (PPDoc _ (DocModule str)) = showChar '"' . showString str . showChar '"' + showsPrec _ (PPDoc d (DocEmphasis doc)) = showChar '/' . shows (PPDoc d doc) . showChar '/' + showsPrec _ (PPDoc d (DocMonospaced doc)) = showChar '@' . shows (PPDoc d doc) . showChar '@' + showsPrec _ (PPDoc d (DocUnorderedList l)) = + foldr (\s r -> showString "* " . shows (PPDoc d s) . showChar '\n' . r) id l + showsPrec _ (PPDoc d (DocOrderedList l)) = + foldr (\(i,n) _f -> shows n . showSpace . shows (PPDoc d i)) id (zip l [1 .. length l]) + showsPrec _ (PPDoc d (DocDefList li)) = + foldr (\(l,r) f -> showString "[@" . shows (PPDoc d l) . showString "[@ " . shows (PPDoc d r) . f) id li + showsPrec _ (PPDoc d (DocCodeBlock doc)) = showChar '@' . shows (PPDoc d doc) . showChar '@' +#if MIN_VERSION_ghc(7,6,0) + showsPrec _ (PPDoc _ (DocHyperlink h)) = showChar '<' . showString (show h) . showChar '>' +#else + showsPrec _ (PPDoc _ (DocURL str)) = showChar '<' . showString str . showChar '>' +#endif + showsPrec _ (PPDoc _ (DocAName str)) = showChar '#' . showString str . showChar '#' + showsPrec _ (PPDoc _ _) = id -attachComments' :: [LSig Name] -> [MyLDocDecl] -> [(LHsDecl Name, Maybe (HsDoc Name))] -attachComments' sigs docs = collectDocs' $ sortByLoc $ +attachComments' :: DynFlags -> [LSig Name] -> [MyLDocDecl] -> [(LHsDecl Name, Maybe (HsDoc Name))] +attachComments' dflags sigs docs = collectDocs' dflags $ sortByLoc $ ((map (\ (L l i) -> L l (SigD i)) sigs) ++ (map (\ (L l i) -> L l (DocD i)) docs)) -- | Collect the docs and attach them to the right declaration. -collectDocs' :: [LHsDecl Name] -> [(LHsDecl Name, (Maybe (HsDoc Name)))] -collectDocs' = collect' Nothing DocEmpty +collectDocs' :: DynFlags -> [LHsDecl Name] -> [(LHsDecl Name, (Maybe (HsDoc Name)))] +collectDocs' dflags = collect' dflags Nothing DocEmpty -collect' :: Maybe (LHsDecl Name) -> HsDoc Name -> [LHsDecl Name] -> [(LHsDecl Name, (Maybe (HsDoc Name)))] -collect' d doc_so_far [] = +collect' :: DynFlags -> Maybe (LHsDecl Name) -> HsDoc Name -> [LHsDecl Name] -> [(LHsDecl Name, (Maybe (HsDoc Name)))] +collect' _dflags d doc_so_far [] = case d of Nothing -> [] Just d0 -> finishedDoc' d0 doc_so_far [] -collect' d doc_so_far (e:es) = +collect' dflags d doc_so_far (e:es) = case e of L _ (DocD (DocCommentNext str)) -> case d of - Nothing -> collect' d (DocAppend doc_so_far (DocString (show' str))) es - Just d0 -> finishedDoc' d0 doc_so_far (collect' Nothing (DocString (show' str)) es) + Nothing -> collect' dflags d (DocAppend doc_so_far (DocString (show' dflags str))) es + Just d0 -> finishedDoc' d0 doc_so_far (collect' dflags Nothing (DocString (show' dflags str)) es) - L _ (DocD (DocCommentPrev str)) -> collect' d (DocAppend doc_so_far (DocString (show' str))) es + L _ (DocD (DocCommentPrev str)) -> collect' dflags d (DocAppend doc_so_far (DocString (show' dflags str))) es _ -> case d of - Nothing -> collect' (Just e) doc_so_far es - Just d0 -> finishedDoc' d0 doc_so_far (collect' (Just e) DocEmpty es) + Nothing -> collect' dflags (Just e) doc_so_far es + Just d0 -> finishedDoc' d0 doc_so_far (collect' dflags (Just e) DocEmpty es) finishedDoc' :: LHsDecl alpha -> NDoc -> [(LHsDecl alpha, (Maybe ((HsDoc Name))))] -> [(LHsDecl alpha, (Maybe ((HsDoc Name))))] 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 @@ -19,6 +19,8 @@ , sourceForPackage , parseSourceForPackageDB , getSourcesMap +, getDataDir +, P.version ) where @@ -53,9 +55,13 @@ #endif import Data.Maybe (catMaybes) import IDE.Core.CTypes (packageIdentifierFromString) -import Paths_leksah_server +import qualified Paths_leksah_server as P (getDataDir, version) import System.Log.Logger(errorM,debugM) import System.IO.Strict as S (readFile) +import System.Environment.Executable (getExecutablePath) +import System.FilePath + (takeDirectory, (), takeFileName) +import System.Directory (doesDirectoryExist) -- --------------------------------------------------------------------- -- Function to map packages to file paths @@ -235,5 +241,14 @@ cabalMinimalP "cabal minimal" +getDataDir :: IO FilePath +getDataDir = do + exePath <- getExecutablePath + if takeFileName exePath `elem` ["leksah-server.exe", "leksah.exe"] + then do + let dataDir = (takeDirectory $ takeDirectory exePath) "leksah" + exists <- doesDirectoryExist dataDir + if exists then return dataDir else P.getDataDir + else P.getDataDir 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 @@ -35,7 +35,12 @@ #if !MIN_VERSION_ghc(7,2,0) import HscTypes hiding (liftIO) #endif +#if MIN_VERSION_ghc(7,6,0) import Outputable hiding(trace) +#else +import Outputable hiding(trace, showSDoc, showSDocUnqual) +import qualified Outputable as O +#endif import ErrUtils import qualified Data.Map as Map import Data.Map(Map) @@ -54,9 +59,10 @@ import StringBuffer(hGetStringBuffer) import Data.List(partition,sortBy,nub,find) import Data.Ord(comparing) -import RdrName (showRdrName) import GHC.Exception +#if !MIN_VERSION_ghc(7,6,0) import MyMissing(forceHead) +#endif import LoadIface(findAndReadIface) import Distribution.Text(display) import TcRnMonad (initTcRnIf, IfGblEnv(..)) @@ -75,13 +81,13 @@ #else import GHC.Show(showSpace) #endif +import Control.Exception as E type NDecl = LHsDecl RdrName myDocEmpty :: NDoc myDocAppend :: NDoc -> NDoc -> NDoc isEmptyDoc :: NDoc -> Bool - #if MIN_VERSION_ghc(6,12,1) type NDoc = HsDocString type MyLDocDecl = LDocDecl @@ -101,6 +107,16 @@ #endif type NSig = Located (Sig RdrName) +#if !MIN_VERSION_ghc(7,6,0) +showSDoc :: DynFlags -> SDoc -> String +showSDoc _ = O.showSDoc +showSDocUnqual :: DynFlags -> SDoc -> String +showSDocUnqual _ = O.showSDocUnqual +#endif + +showRdrName :: DynFlags -> RdrName -> String +showRdrName dflags r = showSDoc dflags (ppr r) + -- | Test collectWorkspace :: PackageIdentifier -> [(String,FilePath)] -> Bool -> Bool -> FilePath -> IO() collectWorkspace packId moduleList forceRebuild writeAscii dir = do @@ -146,25 +162,25 @@ collectModule' :: FilePath -> FilePath -> Bool -> PackageIdentifier -> [String] -> ModuleName -> IO() collectModule' sourcePath destPath writeAscii packId opts moduleName' = gcatch ( - inGhcIO (opts++["-cpp"]) [Opt_Haddock] $ \ _dynFlags -> do + 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' + mbInterfaceDescr <- mayGetInterfaceDescription dynFlags packId moduleName' liftIO $ do stringBuffer <- hGetStringBuffer fp' parseResult <- myParseModule dynFlags3 sourcePath (Just stringBuffer) case parseResult of Right (L _ hsMod@(HsModule{})) -> do - let moduleDescr = extractModDescr packId moduleName' sourcePath hsMod + let moduleDescr = extractModDescr dynFlags packId moduleName' sourcePath hsMod let moduleDescr' = case mbInterfaceDescr of Nothing -> moduleDescr Just md -> mergeWithInterfaceDescr moduleDescr md - catch (writeExtractedModule destPath writeAscii moduleDescr') - (\ _ -> errorM "leksah-server" ("Can't write extracted package " ++ destPath)) + E.catch (writeExtractedModule destPath writeAscii moduleDescr') + (\ (_::IOException) -> errorM "leksah-server" ("Can't write extracted package " ++ destPath)) Left errMsg -> do errorM "leksah-server" $ "Failed to parse " ++ sourcePath ++ " " ++ show errMsg let moduleDescr = ModuleDescr { @@ -175,14 +191,18 @@ dscName' = "Parse Error" , dscMbTypeStr' = Nothing , dscMbModu' = Just (PM packId moduleName') +#if MIN_VERSION_ghc(7,7,0) + , dscMbLocation' = srcSpanToLocation $ errMsgSpan errMsg +#else , dscMbLocation' = case errMsgSpans errMsg of (sp:_) -> srcSpanToLocation sp [] -> Nothing +#endif , dscMbComment' = Just (BS.pack $ show errMsg) , dscTypeHint' = ErrorDescr , dscExported' = False}]} - catch (deepseq moduleDescr $ writeExtractedModule destPath writeAscii moduleDescr) - (\ _ -> errorM "leksah-server" ("Can't write extracted module " ++ destPath)) + E.catch (deepseq moduleDescr $ writeExtractedModule destPath writeAscii moduleDescr) + (\ (_::IOException) -> errorM "leksah-server" ("Can't write extracted module " ++ destPath)) ) (\ (e :: SomeException) -> errorM "leksah-server" ("Can't extract module " ++ destPath ++ " " ++ show e)) @@ -195,22 +215,22 @@ ----------------------------------------------------------------------------------- -- Format conversion -extractModDescr :: PackageIdentifier -> ModuleName -> FilePath -> HsModule RdrName -> ModuleDescr -extractModDescr packId moduleName' sourcePath hsMod = ModuleDescr { +extractModDescr :: DynFlags -> PackageIdentifier -> ModuleName -> FilePath -> HsModule RdrName -> ModuleDescr +extractModDescr dflags packId moduleName' sourcePath hsMod = ModuleDescr { mdModuleId = PM packId moduleName' , mdMbSourcePath = Just sourcePath , mdReferences = Map.empty -- imports , mdIdDescriptions = descrs'} where - descrs = extractDescrs (PM packId moduleName') (hsmodDecls hsMod) - descrs' = fixExports (hsmodExports hsMod) descrs + descrs = extractDescrs dflags (PM packId moduleName') (hsmodDecls hsMod) + descrs' = fixExports dflags (hsmodExports hsMod) descrs ----------------------------------------------------------------------------------- -- Add exported hint -fixExports :: Maybe [LIE RdrName] -> [Descr] -> [Descr] -fixExports Nothing descrs = descrs -fixExports (Just iel) descrs = map (fixDescr (map unLoc iel)) descrs +fixExports :: DynFlags -> Maybe [LIE RdrName] -> [Descr] -> [Descr] +fixExports _ Nothing descrs = descrs +fixExports dflags (Just iel) descrs = map (fixDescr (map unLoc iel)) descrs where fixDescr :: [IE RdrName] -> Descr -> Descr fixDescr _ d@(Reexported _) = d @@ -223,18 +243,18 @@ Nothing -> nothingExported rd Just (IEThingAll _) -> allExported rd Just (IEThingAbs _) -> someExported rd [] - Just (IEThingWith _ l) -> someExported rd (map showRdrName l) + Just (IEThingWith _ l) -> someExported rd (map (showRdrName dflags) l) _ -> allExported rd findVar = find (\ a -> case a of - IEVar r | showRdrName r == dscName' rd -> True + IEVar r | showRdrName dflags r == dscName' rd -> True _ -> False) list findThing = find (\ a -> case a of - IEThingAbs r | showRdrName r == dscName' rd -> True - IEThingAll r | showRdrName r == dscName' rd -> True - IEThingWith r _list | showRdrName r == dscName' rd -> True + IEThingAbs r | showRdrName dflags r == dscName' rd -> True + IEThingAll r | showRdrName dflags r == dscName' rd -> True + IEThingWith r _list | showRdrName dflags r == dscName' rd -> True _ -> False) list allExported rd = rd @@ -265,14 +285,14 @@ maySetExportedSD list sd = sd{sdExported = elem (sdName sd) list} -extractDescrs :: PackModule -> [NDecl] -> [Descr] -extractDescrs pm decls = transformToDescrs pm tripleWithSigs +extractDescrs :: DynFlags -> PackModule -> [NDecl] -> [Descr] +extractDescrs dflags pm decls = transformToDescrs dflags pm tripleWithSigs where sortedDecls = sortByLoc decls pairedWithDocs = collectDocs sortedDecls filteredDecls = filterUninteresting pairedWithDocs (withoutSignatures,signatures) = partitionSignatures filteredDecls - tripleWithSigs = attachSignatures signatures withoutSignatures + tripleWithSigs = attachSignatures dflags signatures withoutSignatures -- | Sort by source location sortByLoc :: [Located a] -> [Located a] @@ -343,15 +363,15 @@ sigNameNoLoc' = maybe [] (:[]) . sigNameNoLoc #endif -attachSignatures :: [(NDecl, (Maybe NDoc))] -> [(NDecl,Maybe NDoc)] +attachSignatures :: DynFlags -> [(NDecl, (Maybe NDoc))] -> [(NDecl,Maybe NDoc)] -> [(NDecl, (Maybe NDoc), [(NSig,Maybe NDoc)])] -attachSignatures signatures = map (attachSignature signaturesMap) +attachSignatures dflags signatures = map (attachSignature signaturesMap) where signaturesMap = Map.fromListWith (++) $ concatMap sigMap signatures sigMap (L loc (SigD sig),c) | nameList <- sigNameNoLoc' sig = map (\n -> (n, [(L loc sig,c)])) nameList - sigMap v = error ("Unexpected location type" ++ (showSDoc . ppr) v) + sigMap v = error ("Unexpected location type" ++ (showSDoc dflags . ppr) v) attachSignature :: Map RdrName [(NSig,Maybe NDoc)] -> (NDecl, (Maybe NDoc)) -> (NDecl, (Maybe NDoc), [(NSig,Maybe NDoc)]) @@ -366,24 +386,119 @@ declName _ = Nothing -transformToDescrs :: PackModule -> [(NDecl, (Maybe NDoc), [(NSig, Maybe NDoc)])] -> [Descr] -transformToDescrs pm = concatMap transformToDescr +transformToDescrs :: DynFlags -> PackModule -> [(NDecl, (Maybe NDoc), [(NSig, Maybe NDoc)])] -> [Descr] +transformToDescrs dflags pm = concatMap transformToDescr where transformToDescr :: (NDecl, (Maybe NDoc), [(NSig, Maybe NDoc)]) -> [Descr] transformToDescr ((L loc (ValD (FunBind lid _ _ _ _ _))), mbComment,sigList) = [Real $ RealDescr { - dscName' = showRdrName (unLoc lid) - , dscMbTypeStr' = sigToByteString sigList + dscName' = showRdrName dflags (unLoc lid) + , dscMbTypeStr' = sigToByteString dflags sigList , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment (catMaybes (map snd sigList)) , dscTypeHint' = VariableDescr , dscExported' = True}] +#if MIN_VERSION_ghc(7,7,0) + transformToDescr ((L loc (TyClD typ@(ForeignType {tcdLName = lid}))), mbComment,_sigList) = + [Real $ RealDescr { + dscName' = showRdrName dflags (unLoc lid) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) + , dscMbModu' = Just pm + , dscMbLocation' = srcSpanToLocation loc + , dscMbComment' = toComment mbComment [] + , dscTypeHint' = TypeDescr + , dscExported' = True}] + + transformToDescr ((L loc (TyClD typ@(FamDecl {tcdFam = (FamilyDecl{ fdLName = lid})}))), mbComment,_sigList) = + [Real $ RealDescr { + dscName' = showRdrName dflags (unLoc lid) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) + , dscMbModu' = Just pm + , dscMbLocation' = srcSpanToLocation loc + , dscMbComment' = toComment mbComment [] + , dscTypeHint' = TypeDescr + , dscExported' = True}] + + transformToDescr ((L loc (TyClD typ@(SynDecl {tcdLName = lid}))), mbComment,_sigList) = + [Real $ RealDescr { + dscName' = showRdrName dflags (unLoc lid) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) + , dscMbModu' = Just pm + , dscMbLocation' = srcSpanToLocation loc + , dscMbComment' = toComment mbComment [] + , dscTypeHint' = TypeDescr + , dscExported' = True}] + + transformToDescr ((L loc (TyClD typ@(DataDecl {tcdLName = lid, tcdDataDefn = HsDataDefn {dd_cons=lConDecl, dd_derivs=tcdDerivs'}}))), mbComment,_sigList) = + [Real $ RealDescr { + dscName' = name + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ))) + , dscMbModu' = Just pm + , dscMbLocation' = srcSpanToLocation loc + , dscMbComment' = toComment mbComment [] + , dscTypeHint' = DataDescr constructors fields + , dscExported' = True}] + ++ derivings tcdDerivs' + where + constructors = map (extractConstructor dflags) lConDecl + fields = nub $ concatMap (extractRecordFields dflags) lConDecl + name = showRdrName dflags (unLoc lid) + derivings Nothing = [] + derivings (Just l) = map (extractDeriving dflags pm name) l +#elif MIN_VERSION_ghc(7,6,0) + transformToDescr ((L loc (TyClD typ@(ForeignType {tcdLName = lid}))), mbComment,_sigList) = + [Real $ RealDescr { + dscName' = showRdrName dflags (unLoc lid) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) + , dscMbModu' = Just pm + , dscMbLocation' = srcSpanToLocation loc + , dscMbComment' = toComment mbComment [] + , dscTypeHint' = TypeDescr + , dscExported' = True}] + + transformToDescr ((L loc (TyClD typ@(TyFamily {tcdLName = lid}))), mbComment,_sigList) = + [Real $ RealDescr { + dscName' = showRdrName dflags (unLoc lid) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) + , dscMbModu' = Just pm + , dscMbLocation' = srcSpanToLocation loc + , dscMbComment' = toComment mbComment [] + , dscTypeHint' = TypeDescr + , dscExported' = True}] + + transformToDescr ((L loc (TyClD typ@(TyDecl {tcdLName = lid, tcdTyDefn = TySynonym {}}))), mbComment,_sigList) = + [Real $ RealDescr { + dscName' = showRdrName dflags (unLoc lid) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) + , dscMbModu' = Just pm + , dscMbLocation' = srcSpanToLocation loc + , dscMbComment' = toComment mbComment [] + , dscTypeHint' = TypeDescr + , dscExported' = True}] + + transformToDescr ((L loc (TyClD typ@(TyDecl {tcdLName = lid, tcdTyDefn = TyData {td_cons=lConDecl, td_derivs=tcdDerivs'}}))), mbComment,_sigList) = + [Real $ RealDescr { + dscName' = name + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ))) + , dscMbModu' = Just pm + , dscMbLocation' = srcSpanToLocation loc + , dscMbComment' = toComment mbComment [] + , dscTypeHint' = DataDescr constructors fields + , dscExported' = True}] + ++ derivings tcdDerivs' + where + constructors = map (extractConstructor dflags) lConDecl + fields = nub $ concatMap (extractRecordFields dflags) lConDecl + name = showRdrName dflags (unLoc lid) + derivings Nothing = [] + derivings (Just l) = map (extractDeriving dflags pm name) l +#else transformToDescr ((L loc (TyClD typ@(TySynonym lid _ _ _ ))), mbComment,_sigList) = [Real $ RealDescr { - dscName' = showRdrName (unLoc lid) - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr typ)) + dscName' = showRdrName dflags (unLoc lid) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] @@ -393,7 +508,7 @@ transformToDescr ((L loc (TyClD typ@(TyData DataType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_sigList) = [Real $ RealDescr { dscName' = name - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr (uncommentData typ))) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] @@ -401,16 +516,16 @@ , dscExported' = True}] ++ derivings tcdDerivs' where - constructors = map extractConstructor lConDecl - fields = nub $ concatMap extractRecordFields lConDecl - name = showRdrName (unLoc tcdLName') + constructors = map (extractConstructor dflags) lConDecl + fields = nub $ concatMap (extractRecordFields dflags) lConDecl + name = showRdrName dflags (unLoc tcdLName') derivings Nothing = [] - derivings (Just l) = map (extractDeriving pm name) l + derivings (Just l) = map (extractDeriving dflags pm name) l transformToDescr ((L loc (TyClD typ@(TyData NewType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_sigList) = [Real $ RealDescr { dscName' = name - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr (uncommentData typ))) + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] @@ -418,39 +533,46 @@ , dscExported' = True}] ++ derivings tcdDerivs' where - constructor = forceHead (map extractConstructor lConDecl) + constructor = forceHead (map (extractConstructor dflags) lConDecl) "WorkspaceCollector>>transformToDescr: no constructor for newtype" - mbField = case concatMap extractRecordFields lConDecl of + mbField = case concatMap (extractRecordFields dflags) lConDecl of [] -> Nothing a:_ -> Just a - name = showRdrName (unLoc tcdLName') + name = showRdrName dflags (unLoc tcdLName') derivings Nothing = [] - derivings (Just l) = map (extractDeriving pm name) l + derivings (Just l) = map (extractDeriving dflags pm name) l +#endif 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})) + dscName' = showRdrName dflags (unLoc tcdLName') + , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr cl{tcdMeths = emptyLHsBinds})) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = ClassDescr super methods , dscExported' = True }] where - methods = extractMethods tcdSigs' docs + methods = extractMethods dflags tcdSigs' docs super = [] +#if MIN_VERSION_ghc(7,7,0) + transformToDescr ((L loc (InstD _inst@(ClsInstD typ))), mbComment, _sigList) = +#elif MIN_VERSION_ghc(7,6,0) + transformToDescr ((L loc (InstD _inst@(ClsInstD typ _ _ _))), mbComment, _sigList) = +#else transformToDescr ((L loc (InstD _inst@(InstDecl typ _ _ _))), mbComment, _sigList) = +#endif [Real $ RealDescr { dscName' = name - , dscMbTypeStr' = Just (BS.pack ("instance " ++ (showSDocUnqual $ppr typ))) + , dscMbTypeStr' = Just (BS.pack ("instance " ++ (showSDocUnqual dflags $ppr typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = InstanceDescr other , dscExported' = True}] where - (name,other) = case words (showSDocUnqual $ppr typ) of + (name,other) = case words (showSDocUnqual dflags $ppr typ) of [] -> ("",[]) hd:tl -> (hd,tl) @@ -458,7 +580,15 @@ uncommentData :: TyClDecl a -> TyClDecl a +#if MIN_VERSION_ghc(7,7,0) +uncommentData td@(DataDecl {tcdDataDefn = def@(HsDataDefn{dd_cons = conDecls})}) = td{ + tcdDataDefn = def{dd_cons = map uncommentDecl conDecls}} +#elif MIN_VERSION_ghc(7,6,0) +uncommentData td@(TyDecl {tcdTyDefn = def@(TyData{td_cons = conDecls})}) = td{ + tcdTyDefn = def{td_cons = map uncommentDecl conDecls}} +#else uncommentData td@(TyData {tcdCons = conDecls}) = td{tcdCons = map uncommentDecl conDecls} +#endif uncommentData other = other uncommentDecl :: LConDecl a -> LConDecl a @@ -489,8 +619,8 @@ Just d -> dscMbTypeStr d} addType _ d = d -extractDeriving :: OutputableBndr alpha => PackModule -> String -> LHsType alpha -> Descr -extractDeriving pm name (L loc typ) = +extractDeriving :: OutputableBndr alpha => DynFlags -> PackModule -> String -> LHsType alpha -> Descr +extractDeriving dflags pm name (L loc typ) = Real $ RealDescr { dscName' = className , dscMbTypeStr' = Just (BS.pack ("instance " ++ (className ++ " " ++ name))) @@ -500,61 +630,61 @@ , dscTypeHint' = InstanceDescr (words name) , dscExported' = True} where - className = showSDocUnqual $ ppr typ + className = showSDocUnqual dflags $ ppr typ -extractMethods :: [LSig RdrName] -> [MyLDocDecl] -> [SimpleDescr] -extractMethods sigs docs = +extractMethods :: DynFlags -> [LSig RdrName] -> [MyLDocDecl] -> [SimpleDescr] +extractMethods dflags sigs docs = let pairs = attachComments sigs docs - in mapMaybe extractMethod pairs + in mapMaybe (extractMethod dflags) pairs -extractMethod :: OutputableBndr alpha => (LHsDecl alpha, Maybe (NDoc)) -> Maybe SimpleDescr +extractMethod :: OutputableBndr alpha => DynFlags -> (LHsDecl alpha, Maybe (NDoc)) -> Maybe SimpleDescr #if MIN_VERSION_ghc(7,2,0) -extractMethod ((L loc (SigD ts@(TypeSig [name] _typ))), mbDoc) = +extractMethod dflags ((L loc (SigD ts@(TypeSig [name] _typ))), mbDoc) = #else -extractMethod ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) = +extractMethod dflags ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) = #endif Just $ SimpleDescr - ((showSDoc . ppr) (unLoc name)) - (Just (BS.pack (showSDocUnqual $ ppr ts))) + ((showSDoc dflags . ppr) (unLoc name)) + (Just (BS.pack (showSDocUnqual dflags $ ppr ts))) (srcSpanToLocation loc) (toComment mbDoc []) True -extractMethod (_, _mbDoc) = Nothing +extractMethod _ (_, _mbDoc) = Nothing -extractConstructor :: Located (ConDecl RdrName) -> SimpleDescr -extractConstructor decl@(L loc (ConDecl {con_name = name, con_doc = doc})) = +extractConstructor :: DynFlags -> Located (ConDecl RdrName) -> SimpleDescr +extractConstructor dflags decl@(L loc (ConDecl {con_name = name, con_doc = doc})) = SimpleDescr - ((showSDoc . ppr) (unLoc name)) - (Just (BS.pack (showSDocUnqual $ppr (uncommentDecl decl)))) + ((showSDoc dflags . ppr) (unLoc name)) + (Just (BS.pack (showSDocUnqual dflags $ppr (uncommentDecl decl)))) (srcSpanToLocation loc) (case doc of Nothing -> Nothing Just (L _ d) -> Just (BS.pack (printHsDoc d))) True -extractRecordFields :: Located (ConDecl RdrName) -> [SimpleDescr] -extractRecordFields (L _ _decl@(ConDecl {con_details = RecCon flds})) = +extractRecordFields :: DynFlags -> Located (ConDecl RdrName) -> [SimpleDescr] +extractRecordFields dflags (L _ _decl@(ConDecl {con_details = RecCon flds})) = map extractRecordFields' flds where extractRecordFields' _field@(ConDeclField (L loc name) typ doc) = SimpleDescr - ((showSDoc . ppr) name) - (Just (BS.pack (showSDocUnqual $ ppr typ))) + ((showSDoc dflags . ppr) name) + (Just (BS.pack (showSDocUnqual dflags $ ppr typ))) (srcSpanToLocation loc) (case doc of Nothing -> Nothing Just (L _ d) -> Just (BS.pack (printHsDoc d))) True -extractRecordFields _ = [] +extractRecordFields _ _ = [] attachComments :: [LSig RdrName] -> [MyLDocDecl] -> [(LHsDecl RdrName, Maybe (NDoc))] attachComments sigs docs = collectDocs $ sortByLoc $ ((map (\ (L l i) -> L l (SigD i)) sigs) ++ (map (\ (L l i) -> L l (DocD i)) docs)) -sigToByteString :: [(NSig, Maybe NDoc)] -> Maybe ByteString -sigToByteString [] = Nothing -sigToByteString [(sig,_)] = Just (BS.pack (showSDocUnqual $ppr sig)) -sigToByteString ((sig,_):_) = Just (BS.pack (showSDocUnqual $ppr sig)) +sigToByteString :: DynFlags -> [(NSig, Maybe NDoc)] -> Maybe ByteString +sigToByteString _ [] = Nothing +sigToByteString dflags [(sig,_)] = Just (BS.pack (showSDocUnqual dflags $ppr sig)) +sigToByteString dflags ((sig,_):_) = Just (BS.pack (showSDocUnqual dflags $ppr sig)) srcSpanToLocation :: SrcSpan -> Maybe Location #if MIN_VERSION_ghc(7,2,0) @@ -638,16 +768,16 @@ M.Succeeded val -> return (Just val) _ -> return Nothing -mayGetInterfaceDescription :: PackageIdentifier -> ModuleName -> Ghc (Maybe ModuleDescr) -mayGetInterfaceDescription pid mn = do +mayGetInterfaceDescription :: DynFlags -> PackageIdentifier -> ModuleName -> Ghc (Maybe ModuleDescr) +mayGetInterfaceDescription dflags pid mn = do mbIf <- mayGetInterfaceFile pid mn case mbIf of Nothing -> do liftIO $ debugM "leksah-server" ("no interface file for " ++ show mn) return Nothing Just (mif,_) -> - let allDescrs = extractExportedDescrH pid mif - mod' = extractExportedDescrR pid allDescrs mif + let allDescrs = extractExportedDescrH dflags pid mif + mod' = extractExportedDescrR dflags pid allDescrs mif in do liftIO $ debugM "leksah-server" ("interface file for " ++ show mn ++ " descrs: " ++ show (length (mdIdDescriptions mod'))) diff --git a/src/IDE/StrippedPrefs.hs b/src/IDE/StrippedPrefs.hs --- a/src/IDE/StrippedPrefs.hs +++ b/src/IDE/StrippedPrefs.hs @@ -75,31 +75,31 @@ sourceDirectories (\b a -> a{sourceDirectories = b}) , mkFieldS - (paraName <<<- ParaName "Maybe a directory for unpacking cabal packages" $ emptyParams) + (paraName <<<- ParaName "Unpack source for cabal packages to" $ emptyParams) (PP.text . show) readParser unpackDirectory (\b a -> a{unpackDirectory = b}) , mkFieldS - (paraName <<<- ParaName "An URL to load prebuild metadata" $ emptyParams) + (paraName <<<- ParaName "URL from which to download prebuilt metadata" $ emptyParams) (PP.text . show) stringParser retrieveURL (\b a -> a{retrieveURL = b}) , mkFieldS - (paraName <<<- ParaName "A strategy for downloading prebuild metadata" $ emptyParams) + (paraName <<<- ParaName "Strategy for downloading prebuilt metadata" $ emptyParams) (PP.text . show) readParser retrieveStrategy (\b a -> a{retrieveStrategy = b}) , mkFieldS - (paraName <<<- ParaName "Port number for server connection" $ emptyParams) + (paraName <<<- ParaName "Port number for leksah to comunicate with leksah-server" $ emptyParams) (PP.text . show) intParser serverPort (\b a -> a{serverPort = b}) , mkFieldS - (paraName <<<- ParaName "End the server with last connection" $ emptyParams) + (paraName <<<- ParaName "Stop the leksah-server process when leksah disconnects" $ emptyParams) (PP.text . show) boolParser endWithLastConn 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -XScopedTypeVariables -XBangPatterns #-} ----------------------------------------------------------------------------- -- @@ -37,19 +38,20 @@ , autoExtractCabalTarFiles , autoExtractTarFiles , getInstalledPackageIds +, getSourcePackageIds , figureOutGhcOpts , figureOutHaddockOpts , allFilesWithExtensions , myCanonicalizePath ) where +import Prelude hiding (readFile) import System.FilePath (splitFileName, dropExtension, takeExtension, combine, addExtension, (), normalise, splitPath, takeFileName) import Distribution.ModuleName (toFilePath, ModuleName) import Control.Monad (foldM, filterM) import Data.Maybe (catMaybes) -import qualified Data.List as List (init, elem) import Distribution.Simple.PreProcess.Unlit (unlit) import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, @@ -80,6 +82,13 @@ import System.Log.Logger(errorM,warningM,debugM) import IDE.Utils.Tool import Control.Monad.IO.Class (MonadIO(..), MonadIO) +import Control.Exception as E (SomeException, catch) +import System.IO.Strict (readFile) +import qualified Data.Text as T + (map, stripPrefix, isSuffixOf, take, length, unpack, init, last, + words) +import Data.Monoid ((<>)) +import Control.Applicative ((<$>)) haskellSrcExts :: [String] haskellSrcExts = ["hs","lhs","chs","hs.pp","lhs.pp","chs.pp","hsc"] @@ -122,12 +131,12 @@ find' :: [FilePath] -> IO (Maybe FilePath) find' [] = return Nothing -find' (h:t) = catch (do +find' (h:t) = E.catch (do exists <- doesFileExist h if exists then return (Just h) else find' t) - $ \ _ -> return Nothing + $ \ (_ :: SomeException) -> return Nothing -- | The directory where config files reside -- @@ -181,7 +190,7 @@ return (cd fn) allModules :: FilePath -> IO [ModuleName] -allModules filePath = catch (do +allModules filePath = E.catch (do exists <- doesDirectoryExist filePath if exists then do @@ -202,7 +211,7 @@ otherModules <- mapM allModules dirs return (mbModuleNames ++ concat otherModules) else return []) - $ \ _ -> return [] + $ \ (_ :: SomeException) -> return [] allHiFiles :: FilePath -> IO [FilePath] allHiFiles = allFilesWithExtensions [".hi"] True [] @@ -214,7 +223,7 @@ allHaskellSourceFiles = allFilesWithExtensions [".hs",".lhs"] True [] allFilesWithExtensions :: [String] -> Bool -> [FilePath] -> FilePath -> IO [FilePath] -allFilesWithExtensions extensions recurseFurther collecting filePath = catch (do +allFilesWithExtensions extensions recurseFurther collecting filePath = E.catch (do exists <- doesDirectoryExist filePath if exists then do @@ -224,25 +233,25 @@ dirs <- filterM (\f -> doesDirectoryExist f) filesAndDirs' files <- filterM (\f -> doesFileExist f) filesAndDirs' let choosenFiles = filter (\f -> let ext = takeExtension f in - List.elem ext extensions) files + elem ext extensions) files allFiles <- if recurseFurther || (not recurseFurther && null choosenFiles) then foldM (allFilesWithExtensions extensions recurseFurther) (choosenFiles ++ collecting) dirs else return (choosenFiles ++ collecting) return (allFiles) else return collecting) - $ \ _ -> return collecting + $ \ (_ :: SomeException) -> return collecting moduleNameFromFilePath :: FilePath -> IO (Maybe String) -moduleNameFromFilePath fp = catch (do +moduleNameFromFilePath fp = E.catch (do exists <- doesFileExist fp if exists then do str <- readFile fp moduleNameFromFilePath' fp str else return Nothing) - $ \ _ -> return Nothing + $ \ (_ :: SomeException) -> return Nothing moduleNameFromFilePath' :: FilePath -> String -> IO (Maybe String) moduleNameFromFilePath' fp str = do @@ -300,45 +309,43 @@ "midentifier" findKnownPackages :: FilePath -> IO (Set String) -findKnownPackages filePath = catch (do +findKnownPackages filePath = E.catch (do paths <- getDirectoryContents filePath let nameList = map dropExtension $filter (\s -> leksahMetadataSystemFileExtension `isSuffixOf` s) paths return (Set.fromList nameList)) - $ \ _ -> return (Set.empty) + $ \ (_ :: SomeException) -> return (Set.empty) isEmptyDirectory :: FilePath -> IO Bool -isEmptyDirectory filePath = catch (do +isEmptyDirectory filePath = E.catch (do exists <- doesDirectoryExist filePath if exists then do filesAndDirs <- getDirectoryContents filePath return . null $ filter (not . ("." `isPrefixOf`) . takeFileName) filesAndDirs else return False) - (\_ -> return False) + (\ (_ :: SomeException) -> return False) cabalFileName :: FilePath -> IO (Maybe FilePath) -cabalFileName filePath = catch (do +cabalFileName filePath = E.catch (do exists <- doesDirectoryExist filePath if exists then do - filesAndDirs <- getDirectoryContents filePath + filesAndDirs <- map (filePath ) <$> getDirectoryContents filePath files <- filterM (\f -> doesFileExist f) filesAndDirs - let cabalFiles = filter (\f -> let ext = takeExtension f in ext == ".cabal") files - if null cabalFiles - then return Nothing - else if length cabalFiles == 1 - then return (Just $head cabalFiles) - else do - warningM "leksah-server" "Multiple cabal files" - return Nothing + case filter (\f -> let ext = takeExtension f in ext == ".cabal") files of + [f] -> return (Just f) + [] -> return Nothing + _ -> do + warningM "leksah-server" "Multiple cabal files" + return Nothing else return Nothing) - (\_ -> return Nothing) + (\ (_ :: SomeException) -> return Nothing) getCabalUserPackageDir :: IO (Maybe FilePath) getCabalUserPackageDir = do (!output,_) <- runTool' "cabal" ["help"] Nothing - case stripPrefix " " (toolline $ last output) of - Just s | "config" `isSuffixOf` s -> return $ Just $ take (length s - 6) s ++ "packages" + case T.stripPrefix " " (toolline $ last output) of + Just s | "config" `T.isSuffixOf` s -> return . Just . T.unpack $ T.take (T.length s - 6) s <> "packages" _ -> return Nothing autoExtractCabalTarFiles :: FilePath -> IO () @@ -355,7 +362,7 @@ autoExtractTarFiles' :: FilePath -> IO () autoExtractTarFiles' filePath = - catch (do + E.catch (do exists <- doesDirectoryExist filePath if exists then do @@ -376,7 +383,7 @@ mapM_ autoExtractTarFiles' dirs return () else return () - ) $ \ _ -> return () + ) $ \ (_ :: SomeException) -> return () getCollectorPath :: MonadIO m => m FilePath @@ -391,26 +398,39 @@ return filePath getSysLibDir :: IO FilePath -getSysLibDir = catch (do +getSysLibDir = E.catch (do (!output,_) <- runTool' "ghc" ["--print-libdir"] Nothing let libDir = toolline $ head output - libDir2 = if ord (last libDir) == 13 - then List.init libDir + libDir2 = if ord (T.last libDir) == 13 + then T.init libDir else libDir - return (normalise libDir2) - ) $ \ _ -> error ("FileUtils>>getSysLibDir failed") + return . normalise $ T.unpack libDir2 + ) $ \ (_ :: SomeException) -> error ("FileUtils>>getSysLibDir failed") getInstalledPackageIds :: IO [PackageIdentifier] -getInstalledPackageIds = catch (do +getInstalledPackageIds = E.catch (do (!output, _) <- runTool' "ghc-pkg" ["list", "--simple-output"] Nothing - let names = toolline $ head output - return (catMaybes (map T.simpleParse (words names))) - ) $ \ _ -> error ("FileUtils>>getInstalledPackageIds failed") + return $ concatMap names output + ) $ \ (_ :: SomeException) -> error ("FileUtils>>getInstalledPackageIds failed") + where + names (ToolOutput n) = catMaybes (map (T.simpleParse . T.unpack) (T.words n)) + names _ = [] +getSourcePackageIds :: IO [PackageIdentifier] +getSourcePackageIds = E.catch (do + (!output, _) <- runTool' "ghc-pkg" ["list", "--simple-output"] Nothing + return . catMaybes $ map names output + ) $ \ (_ :: SomeException) -> error ("FileUtils>>getInstalledPackageIds failed") + where + names (ToolOutput n) = T.simpleParse . T.unpack $ T.map replaceSpace n + names _ = Nothing + replaceSpace ' ' = '-' + replaceSpace c = c + figureOutHaddockOpts :: IO [String] figureOutHaddockOpts = do (!output,_) <- runTool' "cabal" (["haddock","--with-haddock=leksahecho","--executables"]) Nothing - let opts = concatMap (words . toolline) output + let opts = concatMap (words . T.unpack . toolline) output let res = filterOptGhc opts debugM "leksah-server" ("figureOutHaddockOpts " ++ show res) return res @@ -424,7 +444,7 @@ figureOutGhcOpts = do debugM "leksah-server" "figureOutGhcOpts" (!output,_) <- runTool' "cabal" ["build","--with-ghc=leksahecho"] Nothing - let res = case catMaybes $ map (findMake . toolline) output of + let res = case catMaybes $ map (findMake . T.unpack . toolline) output of options:_ -> words options _ -> [] debugM "leksah-server" $ ("figureOutGhcOpts " ++ show res) 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 @@ -37,7 +37,11 @@ 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(..)) +#if MIN_VERSION_ghc(7,6,0) +#else +import ErrUtils (printBagOfWarnings) +#endif +import ErrUtils (dumpIfSet_dyn,printBagOfErrors,errorsFound,mkPlainErrMsg,showPass,ErrMsg(..)) import Control.Monad (unless) #else import ErrUtils (dumpIfSet_dyn,printErrorsAndWarnings,mkPlainErrMsg,showPass,ErrMsg(..)) @@ -53,22 +57,35 @@ import HscTypes (Ghc(..)) #endif import IDE.Utils.FileUtils (getSysLibDir) +#if MIN_VERSION_ghc(7,7,0) +import DynFlags (DumpFlag(..), GeneralFlag(..), gopt_set) +#endif import DynFlags (dopt_set) import System.Log.Logger(debugM) import Control.Monad.IO.Class (MonadIO(..), MonadIO) +#if !MIN_VERSION_ghc(7,7,0) -- this should not be repeated here, why is it necessary? instance MonadIO Ghc where liftIO ioA = Ghc $ \_ -> ioA +#endif +#if MIN_VERSION_ghc(7,7,0) +inGhcIO :: [String] -> [GeneralFlag] -> (DynFlags -> Ghc a) -> IO a +#else inGhcIO :: [String] -> [DynFlag] -> (DynFlags -> Ghc a) -> IO a +#endif inGhcIO flags' udynFlags ghcAct = do debugM "leksah-server" $ "inGhcIO called with: " ++ show flags' libDir <- getSysLibDir -- (restFlags, _) <- parseStaticFlags (map noLoc flags') runGhc (Just libDir) $ do dynflags <- getSessionDynFlags +#if MIN_VERSION_ghc(7,7,0) + let dynflags' = foldl (\ flags'' flag' -> gopt_set flags'' flag') dynflags udynFlags +#else let dynflags' = foldl (\ flags'' flag' -> dopt_set flags'' flag') dynflags udynFlags +#endif let dynflags'' = dynflags' { hscTarget = HscNothing, ghcMode = CompManager, @@ -101,7 +118,9 @@ getInstalledPackageInfos :: Ghc [PackageConfig] getInstalledPackageInfos = do dflags1 <- getSessionDynFlags +#if !MIN_VERSION_ghc(7,6,0) setSessionDynFlags $ dopt_set dflags1 Opt_ReadUserPackageConf +#endif pkgInfos <- case pkgDatabase dflags1 of Nothing -> return [] #if MIN_VERSION_Cabal(1,8,0) @@ -158,14 +177,22 @@ case unP P.parseModule (mkPState buf' loc dflags) of { #endif - PFailed span' err -> return (Left (mkPlainErrMsg span' err)); +#if MIN_VERSION_ghc(7,6,0) + PFailed span' err -> return (Left (mkPlainErrMsg dflags span' err)); +#else + PFailed span' err -> return (Left (mkPlainErrMsg span' err)); +#endif POk pst rdr_module -> do { #if MIN_VERSION_ghc(7,2,0) let {ms@(warnings, errors) = getMessages pst}; printBagOfErrors dflags errors; +#if MIN_VERSION_ghc(7,6,0) + unless (errorsFound dflags ms) $ printBagOfErrors dflags warnings; +#else unless (errorsFound dflags ms) $ printBagOfWarnings dflags warnings; +#endif #else let {ms = getMessages pst}; printErrorsAndWarnings dflags ms; @@ -181,7 +208,7 @@ -- ToDo: free the string buffer later. }} -myParseHeader :: FilePath -> String -> [String] -> IO (Either String (HsModule RdrName)) +myParseHeader :: FilePath -> String -> [String] -> IO (Either String (DynFlags, HsModule RdrName)) myParseHeader fp _str opts = inGhcIO (opts++["-cpp"]) [] $ \ _dynFlags -> do session <- getSession #if MIN_VERSION_ghc(7,2,0) @@ -193,7 +220,7 @@ stringBuffer <- hGetStringBuffer fp' parseResult <- myParseModuleHeader dynFlags' fp (Just stringBuffer) case parseResult of - Right (L _ mod') -> return (Right mod') + Right (L _ mod') -> return (Right (dynFlags', mod')) Left errMsg -> do let str = "Failed to parse " ++ show errMsg return (Left str) @@ -204,9 +231,9 @@ myParseModuleHeader :: DynFlags -> FilePath -> Maybe StringBuffer -> IO (Either ErrMsg (Located (HsModule RdrName))) myParseModuleHeader dflags src_filename maybe_src_buf - = -------------------------- Parser ---------------- - showPass dflags "Parser" >> - {-# SCC "Parser" #-} do + = -------------------------- Parser ---------------- + showPass dflags "Parser" >> + {-# SCC "Parser" #-} do -- sometimes we already have the buffer in memory, perhaps -- because we needed to parse the imports out of it, or get the @@ -227,14 +254,22 @@ case unP P.parseHeader (mkPState buf' loc dflags) of { #endif - PFailed span' err -> return (Left (mkPlainErrMsg span' err)); +#if MIN_VERSION_ghc(7,6,0) + PFailed span' err -> return (Left (mkPlainErrMsg dflags span' err)); +#else + PFailed span' err -> return (Left (mkPlainErrMsg span' err)); +#endif POk pst rdr_module -> do { #if MIN_VERSION_ghc(7,2,0) let {ms@(warnings, errors) = getMessages pst}; printBagOfErrors dflags errors; +#if MIN_VERSION_ghc(7,6,0) + unless (errorsFound dflags ms) $ printBagOfErrors dflags warnings; +#else unless (errorsFound dflags ms) $ printBagOfWarnings dflags warnings; +#endif #else let {ms = getMessages pst}; printErrorsAndWarnings dflags ms; diff --git a/src/IDE/Utils/Server.hs b/src/IDE/Utils/Server.hs --- a/src/IDE/Utils/Server.hs +++ b/src/IDE/Utils/Server.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XFlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.Server @@ -28,7 +28,7 @@ import System.IO import Control.Concurrent -import Control.Exception hiding (catch) +import Control.Exception as E import Data.Word import System.Log.Logger (infoM) @@ -97,9 +97,10 @@ waitFor (_, mvar) = waitFor mvar acceptance :: Socket -> ServerRoutine -> IO () -acceptance sock action = catch (do +acceptance sock action = E.catch (do dta <- accept sock - forkIO (action dta) >> return ()) print >> + forkIO (action dta) >> return ()) + (\(e :: SomeException) -> print e) >> acceptance sock action 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,635 +1,538 @@ -{-# 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 ()) - +{-# LANGUAGE OverloadedStrings #-} +{-# 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, + readProcessWithExitCode, + terminateProcess + +-- waitForChildren, +-- forkChild + +) where + +import Control.Concurrent + (tryTakeMVar, readMVar, takeMVar, putMVar, + newEmptyMVar, forkIO, newChan, MVar, Chan, writeChan, + getChanContents, dupChan) +import Control.Monad (when, unless) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Data.Maybe (maybeToList) +#ifdef MIN_VERSION_process_leksah +import IDE.System.Process + (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..), + interruptProcessGroup, runCommand, getProcessExitCode, + runProcess, runInteractiveProcess, readProcessWithExitCode, + terminateProcess) +import IDE.System.Process.Internals (StdStream(..)) +#else +import System.Process + (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..), + interruptProcessGroupOf, runCommand, getProcessExitCode, + runProcess, runInteractiveProcess, readProcessWithExitCode, + terminateProcess) +import System.Process.Internals (StdStream(..)) +#endif +import qualified Data.Text as T (null, lines, any, unpack, pack, filter) +import Control.DeepSeq +import System.Log.Logger (debugM) +import System.Exit (ExitCode(..)) +import System.IO + (hClose, hFlush, Handle, hSetBuffering, BufferMode(..)) +import Control.Applicative + ((<$>), (<|>), Alternative, liftA2, liftA) +import Data.Conduit as C + ((=$), ($$), ($=)) +import qualified Data.Conduit as C +import qualified Data.Conduit.Text as CT (decode, utf8) +import qualified Data.Conduit.List as CL + (consume, concatMap, concatMapAccumM, sequence, map) +import qualified Data.Conduit.Binary as CB +import Data.Conduit.Attoparsec (sinkParser) +import qualified Data.Attoparsec.Text as AP + (endOfInput, takeWhile, satisfy, skipWhile, string, Parser, + endOfLine, digit, manyTill, takeWhile1, char) +import Data.Attoparsec.Text (()) +import Data.Char (isDigit) +import Data.Text (replace, Text) +import Data.Monoid ((<>)) +import Data.Text.IO (hPutStrLn) + +data ToolOutput = ToolInput Text + | ToolError Text + | ToolOutput Text + | ToolPrompt Text + | 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 Text Text (C.Sink 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 deriving(Eq, Show) + +toolline :: ToolOutput -> Text +toolline (ToolInput l) = l +toolline (ToolOutput l) = l +toolline (ToolError l) = l +toolline (ToolPrompt l) = l +toolline (ToolExit _code) = "" + +quoteArg :: Text -> Text +quoteArg s | T.any (==' ') s = "\"" <> (escapeQuotes s) <> "\"" +quoteArg s = s + +escapeQuotes :: Text -> Text +escapeQuotes = replace "\"" "\\\"" + +#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 <- C.runResourceT $ out $$ CL.consume + waitForProcess pid + debugM "leksah-server" $ "End: " ++ show (fp, args) + return (output,pid) + +runTool :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> IO (C.Source m 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, +#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{..} + +isolateToFirst p = loop + where + loop = C.await >>= maybe (return ()) (\x -> C.yield x >> when (p x) loop) + +runInteractiveTool :: + ToolState -> + CommandLineReader -> + FilePath -> + [String] -> + Maybe FilePath -> + IO () +runInteractiveTool tool clr 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 + putMVar (toolProcessMVar tool) pid + output <- getOutput clr inp out err pid + + forkIO $ do + commands <- getChanContents (toolCommandsRead tool) + 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 $ do + debugM "leksah-server" $ "Command " ++ T.unpack commandString + putMVar (currentToolCommand tool) command + hPutStrLn inp commandString + hFlush inp + (mapM (C.yield . ToolInput) (T.lines rawCommandString) >> isolateCommandOutput) =$ handler + processCommand remainingCommands inp + + outputSequence :: Handle -> C.Conduit RawToolOutput IO ToolOutput + outputSequence inp = + CL.concatMapAccumM writeCommandOutput (False, False, (outputSyncCommand clr), 0, "") + where + writeCommandOutput (RawToolOutput (ToolPrompt line)) (False, False, (Just outSyncCmd), n, _) = do + debugM "leksah-server" $ "Pre Sync Prompt" + hPutStrLn inp $ outSyncCmd n + hFlush inp + return ((True, False, (Just outSyncCmd), n, line), []) + writeCommandOutput (RawToolOutput (ToolPrompt _))(True, False, mbSyncCmd, n, promptLine) = do + debugM "leksah-server" $ "Unsynced Prompt" + return ((True, False, mbSyncCmd, n, promptLine), []) + writeCommandOutput (RawToolOutput o@(ToolOutput line)) (True, False, mbSyncCmd, n, promptLine) = 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 (RawToolOutput (ToolPrompt _)) (_, _, mbSyncCmd, n, promptLine) = do + debugM "leksah-server" $ "Synced Prompt - Ready For Next Command" + tryTakeMVar (currentToolCommand tool) + return ((False, False, mbSyncCmd, n+1, promptLine), [ToolPrompt promptLine]) + writeCommandOutput (RawToolOutput o@(ToolExit _)) s = do + debugM "leksah-server" $ "Tool Exit" + putMVar (outputClosed tool) True + return (s, [o]) + writeCommandOutput (RawToolOutput o) s = do + return (s, [o]) + writeCommandOutput x s = 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 :: Text +ghciPrompt = "3KM2KWR7LZZbHdXfHUOA5YBBsJVYoCQnKX" + +data CommandLineReader = CommandLineReader { + parseInitialPrompt :: AP.Parser Text, + parseFollowingPrompt :: AP.Parser Text, + errorSyncCommand :: Maybe (Int -> Text), + parseExpectedError :: AP.Parser (Text, Int), + outputSyncCommand :: Maybe (Int -> Text), + isExpectedOutput :: Int -> Text -> Bool + } + +ghciParseInitialPrompt :: AP.Parser Text +ghciParseInitialPrompt = (do + ((AP.string "Prelude") <|> (AP.string "*")) + AP.skipWhile (\c -> c /= '>' && c/= '\n') + AP.string "> " + return "") + "ghciParseInitialPrompt" + +ghciParseFollowingPrompt :: AP.Parser Text +ghciParseFollowingPrompt = (do + T.pack <$> AP.satisfy (/='\n') `AP.manyTill` (AP.string ghciPrompt)) + "ghciParseFollowingPrompt" + +marker :: Int -> Text +marker n = "kMAKWRALZZbHdXfHUOAAYBB" <> (T.pack $ show n) + +parseMarker :: AP.Parser Int +parseMarker = (do + AP.string $ T.pack "kMAKWRALZZbHdXfHUOAAYBB" + nums <- AP.takeWhile isDigit + return . read $ T.unpack nums) + "parseMarker" + +ghciParseExpectedErrorCols :: AP.Parser () +ghciParseExpectedErrorCols = (do + AP.string $ T.pack "0-" + AP.digit + AP.digit + return ()) + <|> (do + AP.string $ T.pack "1-" + AP.digit + AP.digit + return ()) + <|> (do + AP.string $ T.pack "0" + return ()) + <|> (do + AP.string $ T.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 (Text, Int) +ghciParseExpectedError = (do + (\(a, b) -> (T.pack a, b)) <$> AP.satisfy (/='\n') `manyTill'` (do + AP.string "\n:" + AP.takeWhile1 isDigit + AP.string ":" + ghciParseExpectedErrorCols + AP.string ": Not in scope: " + (AP.char '`' <|> AP.char '‛') + result <- parseMarker + (AP.char '\'' <|> AP.char '’') + AP.string "\n" + return result)) + "ghciParseExpectedError" + +ghciIsExpectedOutput :: Int -> Text -> 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 (Text, Int) -> AP.Parser (Either (Text, Int) Text) +parseError expectedErrorParser = (do + expected <- expectedErrorParser + return $ Left expected) + <|> (do + line <- AP.takeWhile (/= '\n') + (AP.endOfInput <|> AP.endOfLine) + return $ Right line) + "parseError" + +getOutput :: MonadIO m => CommandLineReader -> Handle -> Handle -> Handle -> ProcessHandle + -> IO (C.Source m RawToolOutput) +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 -> C.Source m RawToolOutput + enumOutput mvar = loop (0::Int) where + loop closed | closed < 2 = do + v <- liftIO $ takeMVar mvar + nowClosed <- if (v == ToolOutClosed) || (v == ToolErrClosed) + then return (closed + 1) + else C.yield v >> return closed + if nowClosed == 2 + then (liftIO $ waitForProcess pid) >>= (C.yield . RawToolOutput . ToolExit) + else loop nowClosed + loop _ = error "Error in enumOutput" + + readError :: MVar RawToolOutput -> Handle -> MVar Int -> IO () + readError mvar errors foundExpectedError = do + CB.sourceHandle errors $= CT.decode CT.utf8 + $= CL.map (T.filter (/= '\r')) + $= (CL.sequence (sinkParser (parseError $ parseExpectedError clr))) + $$ sendErrors + hClose errors + where + sendErrors = C.awaitForever $ \x -> liftIO $ do + debugM "leksah-server" $ show x + case x of + Left (line, counter) -> do + unless (T.null line) $ putMVar mvar $ RawToolOutput $ ToolError line + putMVar foundExpectedError counter + Right line -> putMVar mvar $ RawToolOutput $ ToolError line + + outputSequence :: AP.Parser ToolOutput -> AP.Parser ToolOutput -> C.Conduit Text IO ToolOutput + outputSequence i1 i2 = loop + where + loop = C.await >>= maybe (return ()) (\x -> C.leftover x >> (sinkParser i1) >>= check) + check line@(ToolPrompt _) = C.yield line >> CL.sequence (sinkParser i2) + check line = C.yield line >> loop + + 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 line) + "parseLines") + parseInitialLines = parseLines (parseInitialPrompt clr) + parseFollowinglines = parseLines (parseFollowingPrompt clr) + CB.sourceHandle output $= CT.decode CT.utf8 + $= CL.map (T.filter (/= '\r')) + $= (outputSequence (parseInitialLines) (parseFollowinglines)) + $$ sendErrors + hClose output + where + sendErrors = loop 0 False "" + where + loop counter errSynced promptLine = do + mbx <- C.await + liftIO $ debugM "leksah-server" $ "sendErrors " ++ show mbx + case mbx of + Nothing -> return () + Just x@(ToolPrompt line) -> do + case (counter, errSynced, errorSyncCommand clr) of + (0, _, _) -> do + loop (counter+1) errSynced line + (_, False, Just syncCmd) -> do + liftIO $ do + debugM "leksah-server" $ "sendErrors - Sync " ++ (T.unpack $ syncCmd counter) + hPutStrLn inp $ syncCmd counter + hFlush inp + waitForError counter + debugM "leksah-server" $ "sendErrors - Synced " ++ show counter + loop (counter+1) True line + (_, True, Just _) -> do + liftIO $ putMVar mvar $ RawToolOutput (ToolPrompt promptLine) + loop (counter+1) False promptLine + _ -> do + liftIO $ putMVar mvar $ RawToolOutput x + loop (counter+1) False promptLine + Just x -> do + liftIO . putMVar mvar $ RawToolOutput x + loop counter errSynced promptLine + + 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 (C.Source m ToolOutput) +getOutputNoPrompt inp out err pid = do + output <- getOutput noInputCommandLineReader inp out err pid + return $ output $= CL.concatMap fromRawOutput + +newGhci' :: [String] -> (C.Sink ToolOutput IO ()) -> IO ToolState +newGhci' flags startupOutputHandler = do + tool <- newToolState + writeChan (toolCommands tool) $ + ToolCommand (":set prompt " <> ghciPrompt) "" startupOutputHandler + runInteractiveTool tool ghciCommandLineReader "ghci" flags Nothing + return tool + +newGhci :: FilePath -> Maybe String -> [String] -> (C.Sink ToolOutput IO ()) -> IO ToolState +newGhci dir mbExe interactiveFlags startupOutputHandler = do + tool <- newToolState + writeChan (toolCommands tool) $ + ToolCommand (":set " <> T.pack (unwords interactiveFlags) <> "\n:set prompt " <> ghciPrompt) "" startupOutputHandler + runInteractiveTool tool ghciCommandLineReader "cabal" + ("repl" : maybeToList mbExe) (Just dir) + return tool + +executeCommand :: ToolState -> String -> String -> C.Sink ToolOutput IO () -> IO () +executeCommand tool command rawCommand handler = do + writeChan (toolCommands tool) $ ToolCommand (T.pack command) (T.pack rawCommand) handler + +executeGhciCommand :: ToolState -> String -> C.Sink 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/src/IDE/Utils/VersionUtils.hs b/src/IDE/Utils/VersionUtils.hs --- a/src/IDE/Utils/VersionUtils.hs +++ b/src/IDE/Utils/VersionUtils.hs @@ -16,33 +16,41 @@ module IDE.Utils.VersionUtils ( getHaddockVersion , getGhcVersion +, getGhcInfo ) where import IDE.Utils.Tool (toolline, runTool') import Data.Char (ord) -import qualified Data.List as List (init) import System.Log.Logger (debugM) +import Control.Exception as E (SomeException, catch) +import qualified Data.Text as T (unlines, unpack, init, last) getGhcVersion :: IO FilePath -getGhcVersion = catch (do +getGhcVersion = E.catch (do (!output,_) <- runTool' "ghc" ["--numeric-version"] Nothing let vers = toolline $ head output - vers2 = if ord (last vers) == 13 - then List.init vers + vers2 = if ord (T.last vers) == 13 + then T.init vers else vers - debugM "leksah-server" $ "Got GHC Version " ++ vers2 - return vers2 - ) $ \ _ -> error ("FileUtils>>getGhcVersion failed") + debugM "leksah-server" $ "Got GHC Version " ++ T.unpack vers2 + return $ T.unpack vers2 + ) $ \ (_ :: SomeException) -> error ("FileUtils>>getGhcVersion failed") +getGhcInfo :: IO String +getGhcInfo = E.catch (do + (!output,_) <- runTool' "ghc" ["--info"] Nothing + return . T.unpack . T.unlines $ map toolline output + ) $ \ (_ :: SomeException) -> error ("FileUtils>>getGhcInfo failed") + getHaddockVersion :: IO String -getHaddockVersion = catch (do +getHaddockVersion = E.catch (do (!output,_) <- runTool' "haddock" ["--version"] Nothing let vers = toolline $ head output - vers2 = if ord (last vers) == 13 - then List.init vers + vers2 = if ord (T.last vers) == 13 + then T.init vers else vers - return vers2 - ) $ \ _ -> error ("FileUtils>>getHaddockVersion failed") + return $ T.unpack vers2 + ) $ \ (_ :: SomeException) -> error ("FileUtils>>getHaddockVersion failed") diff --git a/src/LeksahEcho.hs b/src/LeksahEcho.hs --- a/src/LeksahEcho.hs +++ b/src/LeksahEcho.hs @@ -17,16 +17,19 @@ ) where import System.Environment (getArgs) -import IDE.Utils.VersionUtils (getHaddockVersion, getGhcVersion) +import IDE.Utils.VersionUtils (getHaddockVersion, getGhcVersion, getGhcInfo) main :: IO () main = do args <- getArgs + appendFile "/Users/hamish/lecho.log" $ show args ++ "/n" if elem "--version" args then putStrLn =<< getHaddockVersion else if elem "--ghc-version" args then putStrLn =<< getGhcVersion - else if elem "--numeric-version" args - then putStrLn =<< getGhcVersion - else putStrLn $ unwords args + else if elem "--info" args + then putStrLn =<< getGhcInfo + else if elem "--numeric-version" args + then putStrLn =<< getGhcVersion + else putStrLn $ unwords args diff --git a/tests/TestTool.hs b/tests/TestTool.hs --- a/tests/TestTool.hs +++ b/tests/TestTool.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : Main @@ -30,8 +30,8 @@ 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 System.IO (hPutStr, stdout, hPutStrLn, stderr, hFlush) +import qualified Data.Conduit.List as EL (consume) import Control.Concurrent (threadDelay, forkIO, takeMVar, putMVar, newEmptyMVar) import Control.Monad.IO.Class (liftIO) @@ -135,7 +135,9 @@ sendTest t $ output `check` [ ToolInput "jfkdfjdkl", ToolError "", -#if __GLASGOW_HASKELL__ > 702 +#if __GLASGOW_HASKELL__ > 706 + ToolError ":22:1: Not in scope: ‛jfkdfjdkl’", +#elif __GLASGOW_HASKELL__ > 702 ToolError ":22:1: Not in scope: `jfkdfjdkl'", #else ToolError ":1:1: Not in scope: `jfkdfjdkl'", @@ -159,7 +161,9 @@ ToolInput "", ToolInput "jfkdfjdkl", ToolError "", -#if __GLASGOW_HASKELL__ > 702 +#if __GLASGOW_HASKELL__ > 706 + ToolError ":35:1: Not in scope: ‛jfkdfjdkl’", +#elif __GLASGOW_HASKELL__ > 702 ToolError ":37:1: Not in scope: `jfkdfjdkl'", #else ToolError ":1:1: Not in scope: `jfkdfjdkl'", @@ -228,7 +232,7 @@ ["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" + ["Unterminated", o] -> hPutStr (h o) "Unterminated" >> hFlush (h o) _ -> exitFailure where h "StdErr" = stderr