leksah-server 0.12.1.2 → 0.13.1.0
raw patch · 18 files changed
+1296/−1037 lines, 18 filesdep +attoparsec-conduitdep +conduitdep +executable-pathdep −attoparsec-enumeratordep −enumeratordep ~Cabaldep ~Win32dep ~attoparsec
Dependencies added: attoparsec-conduit, conduit, executable-path, text
Dependencies removed: attoparsec-enumerator, enumerator
Dependency ranges changed: Cabal, Win32, attoparsec, base, binary, bytestring, containers, directory, ghc, haddock, hslogger, leksah-server, ltk, process, unix
Files
- leksah-server.cabal +80/−63
- src/IDE/Core/CTypes.hs +7/−2
- src/IDE/Core/Serializable.hs +3/−2
- src/IDE/HeaderParser.hs +34/−18
- src/IDE/Metainfo/Collector.hs +1/−2
- src/IDE/Metainfo/InterfaceCollector.hs +79/−47
- src/IDE/Metainfo/PackageCollector.hs +6/−7
- src/IDE/Metainfo/SourceCollectorH.hs +175/−104
- src/IDE/Metainfo/SourceDB.hs +16/−1
- src/IDE/Metainfo/WorkspaceCollector.hs +207/−77
- src/IDE/StrippedPrefs.hs +5/−5
- src/IDE/Utils/FileUtils.hs +60/−40
- src/IDE/Utils/GHCUtils.hs +43/−8
- src/IDE/Utils/Server.hs +5/−4
- src/IDE/Utils/Tool.hs +538/−635
- src/IDE/Utils/VersionUtils.hs +20/−12
- src/LeksahEcho.hs +7/−4
- tests/TestTool.hs +10/−6
leksah-server.cabal view
@@ -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
src/IDE/Core/CTypes.hs view
@@ -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
src/IDE/Core/Serializable.hs view
@@ -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
src/IDE/HeaderParser.hs view
@@ -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
src/IDE/Metainfo/Collector.hs view
@@ -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)
src/IDE/Metainfo/InterfaceCollector.hs view
@@ -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
src/IDE/Metainfo/PackageCollector.hs view
@@ -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 ())
src/IDE/Metainfo/SourceCollectorH.hs view
@@ -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))))]
src/IDE/Metainfo/SourceDB.hs view
@@ -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
src/IDE/Metainfo/WorkspaceCollector.hs view
@@ -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')))
src/IDE/StrippedPrefs.hs view
@@ -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
src/IDE/Utils/FileUtils.hs view
@@ -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)
src/IDE/Utils/GHCUtils.hs view
@@ -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;
src/IDE/Utils/Server.hs view
@@ -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
src/IDE/Utils/Tool.hs view
@@ -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 : <maintainer@leksah.org> --- Stability : provisional --- Portability : --- --- | Support for running external tools. Written mainly for GHCi but with --- | support for others in mind. --- ------------------------------------------------------------------------------ - -module IDE.Utils.Tool ( - ToolOutput(..), - toolline, - ToolCommand(..), - ToolState(..), - toolProcess, - newToolState, - runTool, - runTool', - runInteractiveTool, - newGhci, - newGhci', - executeCommand, - executeGhciCommand, - quoteArg, - escapeQuotes,- runCommand,- waitForProcess,- interruptProcessGroupOf,- ProcessHandle,- getProcessExitCode,- runInteractiveProcess,- runProcess - --- waitForChildren, --- forkChild - -) where - -import Control.Concurrent - (tryTakeMVar, readMVar, takeMVar, putMVar, - newEmptyMVar, forkIO, newChan, MVar, Chan, writeChan, - getChanContents, dupChan) -import Control.Monad (forM_, when, unless) -import Control.Monad.IO.Class (liftIO, MonadIO) -import Data.List (stripPrefix) -import Data.Maybe (catMaybes) -#ifdef MIN_VERSION_process_leksah -import IDE.System.Process - (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..),- interruptProcessGroup, runCommand, getProcessExitCode,- runProcess, runInteractiveProcess) -import IDE.System.Process.Internals (StdStream(..)) -#else -import System.Process - (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..),- interruptProcessGroupOf, runCommand, getProcessExitCode,- runProcess, runInteractiveProcess) -import System.Process.Internals (StdStream(..)) -#endif -#if MIN_VERSION_base(4,3,0)-import System.IO (hGetBufSome)-import qualified Data.ByteString.Internal as B - (createAndTrim) -#else-import System.IO (hWaitForInput, hIsEOF)-import qualified Data.ByteString as B - (hGetNonBlocking) -#endif-import Control.DeepSeq -import System.Log.Logger (debugM) -import System.Exit (ExitCode(..)) -import System.IO (hFlush, hPutStrLn, Handle, hSetBuffering, BufferMode(..)) -import Control.Applicative ((<|>), Alternative, liftA2, liftA) ---import Data.Enumerator.Binary as E (enumHandle) -import Data.Enumerator as E - (continue, tryIO, checkContinue0, (=$), (>>==), Stream(..), - Enumeratee, Enumerator, run, ($$), ($=), (>==>)) -import qualified Data.Enumerator as E - (enumList, returnI, Step(..), isEOF, checkDone, yield, - Iteratee(..), sequence, run_) -import qualified Data.Enumerator.Binary as EB (filter) -import Data.Attoparsec.Enumerator (iterParser) -import qualified Data.Attoparsec.Char8 as AP - (endOfInput, takeWhile, satisfy, skipWhile, string, Parser, - endOfLine, digit, manyTill, takeWhile1) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B (unpack, pack) -import Data.Attoparsec ((<?>)) -import qualified Data.Enumerator.List as EL - (consume, concatMap, concatMapAccumM) -import Data.Char (isDigit) -import qualified System.IO as IO (Handle) -import qualified Data.ByteString as B - (empty, null, ByteString) -import System.IO.Error (mkIOError, illegalOperationErrorType) - -data ToolOutput = ToolInput String - | ToolError String - | ToolOutput String - | ToolPrompt String - | ToolExit ExitCode deriving(Eq, Show) - -instance NFData ExitCode where - rnf ExitSuccess = rnf () - rnf (ExitFailure failureCode) = rnf failureCode - -instance NFData ToolOutput where - rnf (ToolInput s) = rnf s - rnf (ToolError s) = rnf s - rnf (ToolOutput s) = rnf s - rnf (ToolPrompt s) = rnf s - rnf (ToolExit code) = rnf code - -data ToolCommand = ToolCommand String String (E.Iteratee ToolOutput IO ()) -data ToolState = ToolState { - toolProcessMVar :: MVar ProcessHandle, - outputClosed :: MVar Bool, - toolCommands :: Chan ToolCommand, - toolCommandsRead :: Chan ToolCommand, - currentToolCommand :: MVar ToolCommand} - -toolProcess :: ToolState -> IO ProcessHandle -toolProcess = readMVar . toolProcessMVar - -data RawToolOutput = RawToolOutput ToolOutput - | ToolOutClosed - | ToolErrClosed - | ToolClosed deriving(Eq, Show) - -toolline :: ToolOutput -> String -toolline (ToolInput l) = l -toolline (ToolOutput l) = l -toolline (ToolError l) = l -toolline (ToolPrompt l) = l -toolline (ToolExit _code) = "" - -quoteArg :: String -> String -quoteArg s | ' ' `elem` s = "\"" ++ (escapeQuotes s) ++ "\"" -quoteArg s = s - -escapeQuotes :: String -> String -escapeQuotes = foldr (\c s -> if c == '"' then '\\':c:s else c:s) "" - -#ifdef MIN_VERSION_process_leksah-interruptProcessGroupOf :: ProcessHandle -> IO ()-interruptProcessGroupOf = interruptProcessGroup-#endif--runTool' :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle) -runTool' fp args mbDir = do - debugM "leksah-server" $ "Start: " ++ show (fp, args) - (out,pid) <- runTool fp args mbDir - output <- E.run_ $ out $$ EL.consume - waitForProcess pid - debugM "leksah-server" $ "End: " ++ show (fp, args) - return (output,pid) - -runTool :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> IO (Enumerator ToolOutput m b, ProcessHandle) -runTool executable arguments mbDir = do - (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments) - { std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe, - cwd = mbDir, -#ifdef MIN_VERSION_process_leksah - new_group = True } -#else - create_group = True } -#endif - output <- getOutputNoPrompt inp out err pid - return (output, pid) - -newToolState :: IO ToolState -newToolState = do - toolProcessMVar <- newEmptyMVar - outputClosed <- newEmptyMVar - toolCommands <- newChan - toolCommandsRead <- dupChan toolCommands - currentToolCommand <- newEmptyMVar - return ToolState{..} - -dropToFirst :: Monad m => (a -> Bool) -> E.Iteratee a m () -dropToFirst p = E.continue loop where - loop (Chunks xs) = case dropWhile p xs of - [] -> E.continue loop - _:xs' -> E.yield () (Chunks xs') - loop EOF = E.yield () EOF - -isolateToFirst :: Monad m => (a -> Bool) -> Enumeratee a a m b -isolateToFirst p (E.Continue k) = E.continue loop where - loop (Chunks []) = E.continue loop - loop (Chunks xs) = - case span p xs of - (_, []) -> k (Chunks xs) >>== isolateToFirst p - (s1, t:s2) -> k (Chunks (s1++[t])) >>== (\step -> E.yield step (Chunks s2)) - loop EOF = k EOF >>== (\step -> E.yield step EOF) -isolateToFirst p step = dropToFirst p >> return step - -runInteractiveTool :: - ToolState -> - CommandLineReader -> - FilePath -> - [String] -> - IO () -runInteractiveTool tool clr executable arguments = do - (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments) - { std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe, -#ifdef MIN_VERSION_process_leksah - new_group = True } -#else - create_group = True } -#endif - putMVar (toolProcessMVar tool) pid - output <- getOutput clr inp out err pid - - forkIO $ do - commands <- getChanContents (toolCommandsRead tool) - E.run_ $ output $$ outputSequence inp $$ processCommand commands inp - return () - return () - where - isEndOfCommandOutput (ToolPrompt _) = True - isEndOfCommandOutput (ToolExit _) = True - isEndOfCommandOutput _ = False - - isolateCommandOutput = isolateToFirst (not . isEndOfCommandOutput) - - processCommand [] _ = do - liftIO $ debugM "leksah-server" $ "No More Commands" - return () - processCommand ((command@(ToolCommand commandString rawCommandString handler)):remainingCommands) inp = do - liftIO $ putMVar (currentToolCommand tool) command - liftIO $ hPutStrLn inp commandString - liftIO $ hFlush inp - - (E.enumList 1 (map ToolInput (lines rawCommandString)) >==> isolateCommandOutput) =$ handler - processCommand remainingCommands inp - - outputSequence :: Handle -> E.Enumeratee RawToolOutput ToolOutput IO b - outputSequence inp = - EL.concatMapAccumM writeCommandOutput (False, False, (outputSyncCommand clr), 0, "") - where - writeCommandOutput (False, False, (Just outSyncCmd), n, _) (RawToolOutput (ToolPrompt line)) = do - debugM "leksah-server" $ "Pre Sync Prompt" - hPutStrLn inp $ outSyncCmd n - hFlush inp - return ((True, False, (Just outSyncCmd), n, line), []) - writeCommandOutput (True, False, mbSyncCmd, n, promptLine) (RawToolOutput (ToolPrompt _)) = do - debugM "leksah-server" $ "Unsynced Prompt" - return ((True, False, mbSyncCmd, n, promptLine), []) - writeCommandOutput (True, False, mbSyncCmd, n, promptLine) (RawToolOutput o@(ToolOutput line)) = do - let synced = (isExpectedOutput clr n line) - when synced $ debugM "leksah-server" $ "Output Sync Found" - return ((True, synced, mbSyncCmd, n, promptLine), if synced then [] else [o]) - writeCommandOutput (_, _, mbSyncCmd, n, promptLine) (RawToolOutput (ToolPrompt _)) = do - debugM "leksah-server" $ "Synced Prompt - Ready For Next Command" - tryTakeMVar (currentToolCommand tool) - return ((False, False, mbSyncCmd, n+1, promptLine), [ToolPrompt promptLine]) - writeCommandOutput s (RawToolOutput o@(ToolExit _)) = do - debugM "leksah-server" $ "Tool Exit" - putMVar (outputClosed tool) True - return (s, [o]) - writeCommandOutput s (RawToolOutput o) = do - return (s, [o]) - writeCommandOutput s x = do - debugM "leksah-server" $ "Unexpected output " ++ show x - return (s, []) - -{- -newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ToolState -newInteractiveTool getOutput' executable arguments = do - tool <- newToolState - runInteractiveTool tool getOutput' executable arguments - return tool --} - -ghciPrompt :: String -ghciPrompt = "3KM2KWR7LZZbHdXfHUOA5YBBsJVYoCQnKX" - -data CommandLineReader = CommandLineReader { - parseInitialPrompt :: AP.Parser String, - parseFollowingPrompt :: AP.Parser String, - errorSyncCommand :: Maybe (Int -> String), - parseExpectedError :: AP.Parser (String, Int), - outputSyncCommand :: Maybe (Int -> String), - isExpectedOutput :: Int -> String -> Bool - } - -ghciParseInitialPrompt :: AP.Parser String -ghciParseInitialPrompt = (do - ((AP.string $ B.pack "Prelude") <|> (AP.string $ B.pack "*")) - AP.skipWhile (\c -> c /= '>' && c/= '\n') - AP.string $ B.pack "> " - return "") - <?> "ghciParseInitialPrompt" - -ghciParseFollowingPrompt :: AP.Parser String -ghciParseFollowingPrompt = (do - AP.satisfy (/='\n') `AP.manyTill` (AP.string $ B.pack $ ghciPrompt)) - <?> "ghciParseFollowingPrompt" - -marker :: Int -> String -marker n = "kMAKWRALZZbHdXfHUOAAYBB" ++ show n - -parseMarker :: AP.Parser Int -parseMarker = (do - AP.string $ B.pack "kMAKWRALZZbHdXfHUOAAYBB" - nums <- AP.takeWhile isDigit - return . read $ B.unpack nums) - <?> "parseMarker" - -ghciParseExpectedErrorCols :: AP.Parser () -ghciParseExpectedErrorCols = (do - AP.string $ B.pack "0-" - AP.digit - AP.digit - return ()) - <|> (do - AP.string $ B.pack "1-" - AP.digit - AP.digit - return ()) - <|> (do - AP.string $ B.pack "0" - return ()) - <|> (do - AP.string $ B.pack "1" - return ()) - <?> "ghciParseExpectedErrorCols" --manyTill' :: Alternative f => f a -> f b -> f ([a], b)-manyTill' p end = scan- where scan = liftA (\b -> ([], b)) end <|> liftA2 (\a (as, b) -> (a:as, b)) p scan- -ghciParseExpectedError :: AP.Parser (String, Int) -ghciParseExpectedError = (do- AP.satisfy (/='\n') `manyTill'` (do - AP.string $ B.pack "\n<interactive>:" - AP.takeWhile1 isDigit - AP.string $ B.pack ":" - ghciParseExpectedErrorCols - AP.string $ B.pack ": Not in scope: `" - result <- parseMarker - AP.string $ B.pack "'\n" - return result)) - <?> "ghciParseExpectedError" - -ghciIsExpectedOutput :: Int -> String -> Bool -ghciIsExpectedOutput n = - (==) (marker n) - -ghciCommandLineReader :: CommandLineReader -ghciCommandLineReader = CommandLineReader { - parseInitialPrompt = ghciParseInitialPrompt, - parseFollowingPrompt = ghciParseFollowingPrompt, - errorSyncCommand = Just $ \n -> marker n, - parseExpectedError = ghciParseExpectedError, - outputSyncCommand = Just $ \n -> ":set prompt \"" ++ marker n ++ "\\n\"\n:set prompt " ++ ghciPrompt, - isExpectedOutput = ghciIsExpectedOutput - } - -noInputCommandLineReader :: CommandLineReader -noInputCommandLineReader = CommandLineReader { - parseInitialPrompt = fail "No Prompt Expected", - parseFollowingPrompt = fail "No Prompt Expected", - errorSyncCommand = Nothing, - parseExpectedError = fail "No Expected Errors", - outputSyncCommand = Nothing, - isExpectedOutput = \_ _ -> False - } - -parseError :: AP.Parser (String, Int) -> AP.Parser (Either (String, Int) ByteString) -parseError expectedErrorParser = (do - expected <- expectedErrorParser - return $ Left expected) - <|> (do - line <- AP.takeWhile (/= '\n') - (AP.endOfInput <|> AP.endOfLine) - return $ Right line) - <?> "parseError" ---- From enumerator but using hGetSome (to fix Win32) -enumHandle :: MonadIO m - => Integer -- ^ Buffer size - -> IO.Handle - -> Enumerator B.ByteString m b -enumHandle bufferSize h = checkContinue0 $ \loop k -> do - let intSize = fromInteger bufferSize - - bytes <- tryIO (hGetSome h intSize) - if B.null bytes - then continue k - else k (Chunks [bytes]) >>== loop ---- From byteString (for GHC 6.12.3 support)-hGetSome :: Handle -> Int -> IO ByteString-hGetSome hh i-#if MIN_VERSION_base(4,3,0)- | i > 0 = B.createAndTrim i $ \p -> hGetBufSome hh p i-#else- | i > 0 = let- loop = do- s <- B.hGetNonBlocking hh i- if not (B.null s)- then return s- else do eof <- hIsEOF hh- if eof then return s- else hWaitForInput hh (-1) >> loop- -- for this to work correctly, the- -- Handle should be in binary mode- -- (see GHC ticket #3808)- in loop-#endif- | i == 0 = return B.empty- | otherwise = illegalBufferSize hh "hGetSome" i--illegalBufferSize :: Handle -> String -> Int -> IO a-illegalBufferSize handle fn sz =- ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing)- --TODO: System.IO uses InvalidArgument here, but it's not exported :-(- where- msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz []- -getOutput :: MonadIO m => CommandLineReader -> Handle -> Handle -> Handle -> ProcessHandle - -> IO (Enumerator RawToolOutput m b) -getOutput clr inp out err pid = do - hSetBuffering out NoBuffering - hSetBuffering err NoBuffering - mvar <- newEmptyMVar - foundExpectedError <- liftIO $ newEmptyMVar - forkIO $ do - readError mvar err foundExpectedError - putMVar mvar ToolErrClosed - forkIO $ do - readOutput mvar out foundExpectedError - putMVar mvar ToolOutClosed - return $ enumOutput mvar - where - enumOutput :: MonadIO m => MVar RawToolOutput -> Enumerator RawToolOutput m b - enumOutput = loop (0::Int) where - loop closed mvar (E.Continue k) | closed < 2 = do - v <- liftIO $ takeMVar mvar - let (nowClosed, chunk) = if (v == ToolOutClosed) || (v == ToolErrClosed) - then (closed + 1, []) - else (closed, [v]) - if nowClosed == 2 - then do - exitCode <- liftIO $ waitForProcess pid - k (Chunks [RawToolOutput (ToolExit exitCode)]) >>== loop nowClosed mvar - else k (Chunks chunk) >>== loop nowClosed mvar - loop _ _ step = E.returnI step - - readError :: MVar RawToolOutput -> Handle -> MVar Int -> IO () - readError mvar errors foundExpectedError = do - result <- E.run $ (enumHandle 2048 errors $= EB.filter (/= 13)) - $$ (E.sequence (iterParser $ parseError (parseExpectedError clr))) - $$ sendErrors - case result of - Left e -> putStrLn $ show e - Right _ -> return () - return () - where - sendErrors = E.continue loop - where - loop (E.Chunks xs) = do - forM_ xs $ \x -> liftIO $ do - debugM "leksah-server" $ show x - case x of - Left (line, counter) -> do- unless (null line) $ putMVar mvar $ RawToolOutput $ ToolError line- putMVar foundExpectedError counter - Right line -> putMVar mvar $ RawToolOutput $ ToolError (B.unpack line) - E.continue loop - loop E.EOF = E.yield () E.EOF - - outputSequence :: E.Iteratee ao IO ToolOutput -> E.Iteratee ao IO ToolOutput -> E.Enumeratee ao ToolOutput IO b - outputSequence i1 i2 = loop i1 where - loop i = E.checkDone check - where - check k = E.isEOF >>= \f -> if f - then E.yield (E.Continue k) EOF - else step k - step k = i >>= \v -> - case v of - ToolPrompt _ -> k (Chunks [v]) >>== loop i2 - _ -> k (Chunks [v]) >>== loop i - - readOutput :: MVar RawToolOutput -> Handle -> MVar Int -> IO () - readOutput mvar output foundExpectedError = do - let parseLines parsePrompt = (do - lineSoFar <- parsePrompt - return $ ToolPrompt lineSoFar) - <|> (do - line <- AP.takeWhile (/= '\n') - (AP.endOfInput <|> AP.endOfLine) - return . ToolOutput $ B.unpack line) - <?> "parseLines" - parseInitialLines = parseLines (parseInitialPrompt clr) - parseFollowinglines = parseLines (parseFollowingPrompt clr) - E.run_ $ (enumHandle 2048 output $= EB.filter (/= 13)) - $$ outputSequence (iterParser parseInitialLines) (iterParser parseFollowinglines) - $$ sendErrors - return () - where - sendErrors = E.continue (loop 0 False "") - where - loop counter errSynced promptLine (E.Chunks xs) = do - forM_ xs $ \x -> do - liftIO $ debugM "leksah-server" $ show x - case x of - ToolPrompt line -> do - case (counter, errSynced, errorSyncCommand clr) of - (0, _, _) -> do - E.continue (loop (counter+1) errSynced line) - (_, False, Just syncCmd) -> do - liftIO $ do - debugM "leksah-server" $ "sendErrors - Sync " ++ show counter - hPutStrLn inp $ syncCmd counter - hFlush inp - waitForError counter - debugM "leksah-server" $ "sendErrors - Synced " ++ show counter - E.continue (loop (counter+1) True line) - (_, True, Just _) -> do - liftIO $ putMVar mvar $ RawToolOutput (ToolPrompt promptLine) - E.continue (loop (counter+1) False promptLine) - _ -> do - liftIO $ putMVar mvar $ RawToolOutput x - E.continue (loop (counter+1) False promptLine) - _ -> do - liftIO . putMVar mvar $ RawToolOutput x - E.continue (loop counter errSynced promptLine) - loop _ _ _ E.EOF = E.yield () E.EOF - - waitForError counter = do - foundCount <- takeMVar foundExpectedError - debugM "leksah-server" $ "waitForError - Found " ++ show foundCount - when (foundCount < counter) $ waitForError counter - - -fromRawOutput :: RawToolOutput -> [ToolOutput] -fromRawOutput (RawToolOutput output) = [output] -fromRawOutput (_) = [] - -getOutputNoPrompt :: MonadIO m => Handle -> Handle -> Handle -> ProcessHandle -> IO (Enumerator ToolOutput m b) -getOutputNoPrompt inp out err pid = do - output <- getOutput noInputCommandLineReader inp out err pid - return $ output $= EL.concatMap fromRawOutput - -newGhci' :: [String] -> (E.Iteratee ToolOutput IO ()) -> IO ToolState -newGhci' flags startupOutputHandler = do - tool <- newToolState - writeChan (toolCommands tool) $ - ToolCommand (":set prompt " ++ ghciPrompt) "" startupOutputHandler - runInteractiveTool tool ghciCommandLineReader "ghci" flags - return tool - -newGhci :: [String] -> [String] -> (E.Iteratee ToolOutput IO ()) -> IO ToolState -newGhci buildFlags interactiveFlags startupOutputHandler = do - tool <- newToolState - writeChan (toolCommands tool) $ - ToolCommand (":set prompt " ++ ghciPrompt) "" startupOutputHandler - debugM "leksah-server" $ "Working out GHCi options" - forkIO $ do - (out, _) <- runTool "cabal" (["build","--with-ghc=leksahecho"] ++ buildFlags) Nothing - output <- E.run_ $ out $$ EL.consume - case catMaybes $ map (findMake . toolline) output of - options:_ -> do - let newOptions = filterUnwanted options - debugM "leksah-server" $ newOptions - debugM "leksah-server" $ "Starting GHCi" - debugM "leksah-server" $ unwords (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags) - runInteractiveTool tool ghciCommandLineReader "ghci" - (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags) - _ -> do - E.run $ E.enumList 1 output $$ startupOutputHandler - putMVar (outputClosed tool) True - return tool - where - findMake [] = Nothing - findMake line@(_:xs) = - case stripPrefix "--make " line of - Nothing -> findMake xs - s -> s - filterUnwanted [] = [] - filterUnwanted line@(x:xs) = - case stripPrefix "-O " line of - Nothing -> x: filterUnwanted xs - Just s -> filterUnwanted s - - -executeCommand :: ToolState -> String -> String -> E.Iteratee ToolOutput IO () -> IO () -executeCommand tool command rawCommand handler = do - writeChan (toolCommands tool) $ ToolCommand command rawCommand handler - -executeGhciCommand :: ToolState -> String -> E.Iteratee ToolOutput IO () -> IO () -executeGhciCommand tool command handler = do - if '\n' `elem` command - then executeCommand tool safeCommand command handler - else executeCommand tool command command handler - where - filteredLines = (filter safeLine (lines command)) - safeCommand = ":cmd (return " ++ show (":{\n" ++ unlines filteredLines ++ "\n:}") ++ ")" - safeLine ":{" = False - safeLine ":}" = False - safeLine _ = True - ---children :: MVar [MVar ()] ---children = unsafePerformIO (newMVar []) --- ---waitForChildren :: IO () ---waitForChildren = do --- cs <- takeMVar children --- case cs of --- [] -> return () --- m:ms -> do --- putMVar children ms --- takeMVar m --- waitForChildren --- ---forkChild :: IO () -> IO ThreadId ---forkChild io = do --- mvar <- newEmptyMVar --- childs <- takeMVar children --- putMVar children (mvar:childs) --- forkIO (io `finally` putMVar mvar ()) - +{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -XRecordWildCards -XCPP -XBangPatterns -fno-warn-orphans #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Utils.Tool+-- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken+-- License : GPL+--+-- Maintainer : <maintainer@leksah.org>+-- Stability : provisional+-- Portability :+--+-- | Support for running external tools. Written mainly for GHCi but with+-- | support for others in mind.+--+-----------------------------------------------------------------------------++module IDE.Utils.Tool (+ ToolOutput(..),+ toolline,+ ToolCommand(..),+ ToolState(..),+ toolProcess,+ newToolState,+ runTool,+ runTool',+ runInteractiveTool,+ newGhci,+ newGhci',+ executeCommand,+ executeGhciCommand,+ quoteArg,+ escapeQuotes,+ runCommand,+ waitForProcess,+ interruptProcessGroupOf,+ ProcessHandle,+ getProcessExitCode,+ runInteractiveProcess,+ runProcess,+ 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<interactive>:"+ 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 ())+
src/IDE/Utils/VersionUtils.hs view
@@ -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")
src/LeksahEcho.hs view
@@ -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
tests/TestTool.hs view
@@ -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 "<interactive>:22:1: Not in scope: ‛jfkdfjdkl’",+#elif __GLASGOW_HASKELL__ > 702 ToolError "<interactive>:22:1: Not in scope: `jfkdfjdkl'", #else ToolError "<interactive>:1:1: Not in scope: `jfkdfjdkl'",@@ -159,7 +161,9 @@ ToolInput "", ToolInput "jfkdfjdkl", ToolError "",-#if __GLASGOW_HASKELL__ > 702+#if __GLASGOW_HASKELL__ > 706+ ToolError "<interactive>:35:1: Not in scope: ‛jfkdfjdkl’",+#elif __GLASGOW_HASKELL__ > 702 ToolError "<interactive>:37:1: Not in scope: `jfkdfjdkl'", #else ToolError "<interactive>: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