leksah-server 0.15.2.0 → 0.16.2.0
raw patch · 21 files changed
+1600/−708 lines, 21 filesdep +aesondep +base-compatdep +doctestdep ~Cabaldep ~HUnitdep ~base
Dependencies added: aeson, base-compat, doctest, ghc-boot
Dependency ranges changed: Cabal, HUnit, base, binary, directory, ghc, haddock-api, haddock-library, leksah-server, ltk, process, time, transformers
Files
- data/prefscoll.lkshp +2/−2
- leksah-server.cabal +258/−122
- main/Collector.hs +37/−36
- main/LeksahEcho.hs +4/−4
- src/IDE/Core/CTypes.hs +26/−7
- src/IDE/Core/Serializable.hs +27/−9
- src/IDE/HeaderParser.hs +33/−5
- src/IDE/Metainfo/InterfaceCollector.hs +108/−71
- src/IDE/Metainfo/PackageCollector.hs +156/−26
- src/IDE/Metainfo/SourceCollectorH.hs +118/−37
- src/IDE/Metainfo/SourceDB.hs +11/−11
- src/IDE/Metainfo/WorkspaceCollector.hs +251/−130
- src/IDE/StrippedPrefs.hs +1/−1
- src/IDE/Utils/CabalPlan.hs +153/−0
- src/IDE/Utils/CabalProject.hs +92/−0
- src/IDE/Utils/FileUtils.hs +172/−61
- src/IDE/Utils/GHCUtils.hs +37/−105
- src/IDE/Utils/Server.hs +1/−1
- src/IDE/Utils/Tool.hs +57/−48
- src/IDE/Utils/VersionUtils.hs +23/−9
- tests/TestTool.hs +33/−23
data/prefscoll.lkshp view
@@ -1,9 +1,9 @@ Paths under which haskell sources for packages may be found: [] Unpack source for cabal packages to:- Just "~/.leksah-0.15/packageSources"+ Just "~/.leksah-0.16/packageSources" URL from which to download prebuilt metadata:- "http://www.leksah.org"+ "http://leksah.github.io" Strategy for downloading prebuilt metadata: RetrieveThenBuild Port number for leksah to comunicate with leksah-server:
leksah-server.cabal view
@@ -1,6 +1,6 @@ name: leksah-server-version: 0.15.2.0-cabal-version: >= 1.10.2+version: 0.16.2.0+cabal-version: >=1.10.2 build-type: Simple license: GPL license-file: LICENSE@@ -11,180 +11,316 @@ package-url: http://code.haskell.org/leksah-collector bug-reports: http://code.google.com/p/leksah/issues/list synopsis: Metadata collection for leksah-description: The interface to GHC-API for leksah+description:+ The interface to GHC-API for leksah category: IDE author: Juergen "jutaro" Nicklisch-Franken, Hamish Mackenzie-data-dir: ""-tested-with: GHC ==7.4 || ==7.6 || ==7.8+tested-with: GHC == 8.2.1, GHC == 8.0.2 data-files:- data/prefscoll.lkshp+ data/prefscoll.lkshp source-repository head- type: git- location: https://github.com/leksah/leksah-server+ type: git+ location: https://github.com/leksah/leksah-server flag threaded- default: True- description: Build with support for multithreaded execution+ description:+ Build with support for multithreaded execution flag network-uri- description: Get Network.URI from the network-uri package- default: True+ description:+ Get Network.URI from the network-uri package library- default-language: Haskell98- build-depends: Cabal >=1.10.2.0 && <1.23, base >= 4.0.0.0 && <4.9, 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.5, ghc >=7.0.4 && <7.11,- ltk >=0.15.0.1 && <0.16, parsec >=3.0.0.0 && <3.2,- pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.6, deepseq >=1.1 && <1.5,- hslogger >= 1.0.7 && <1.3, conduit >= 1.0.8 && <1.3,- conduit-extra >=1.0.0.1 && <1.2, resourcet,- attoparsec >=0.10.0.3 && <0.14,- transformers >=0.2.2.0 && <0.5, strict >=0.3.2 && <0.4, text >=0.11.3.1 && <1.3,- HTTP >=4000.1.2 && <4000.4, process >= 1.1 && <1.3- if (impl(ghc >= 7.10))- build-depends: haddock-api >=2.16 && <2.17, haddock-library >=1.2.0 && <1.3, bin-package-db- else- if (impl(ghc >= 7.8))- build-depends: haddock-api >= 2.7.2 && <2.16- else- if (impl(ghc >= 7.6))- build-depends: haddock >= 2.7.2 && <2.14++ if !impl(ghcjs)+ if impl(ghc >=8.2)+ build-depends:+ haddock-api >=2.18.1 && <2.19,+ haddock-library >=1.4.1 && <1.5,+ ghc-boot >=8.2.1 && <8.3 else- if (impl(ghc >= 7.4.2))- build-depends: haddock >= 2.11.1 && <2.12- else- if (impl(ghc >= 7.4))- build-depends: haddock >= 2.7.2 && <2.11++ if impl(ghc >=8.0)+ build-depends:+ haddock-api >=2.17.2 && <2.18,+ haddock-library >=1.4.1 && <1.5,+ ghc-boot >=8.0.1 && <8.1 else- if (impl(ghc >= 7.2))- build-depends: haddock >= 2.7.2 && <2.10- else- build-depends: haddock >= 2.7.2 && <2.9.3 + if impl(ghc >=7.10)+ build-depends:+ haddock-api >=2.16 && <2.17,+ haddock-library >=1.2.0 && <1.3,+ bin-package-db -any+ else++ if impl(ghc >=7.8)+ build-depends:+ haddock-api >=2.7.2 && <2.16+ else++ 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.4)+ build-depends:+ haddock >=2.7.2 && <2.11+ else++ if impl(ghc >=7.2)+ build-depends:+ haddock >=2.7.2 && <2.10+ else+ build-depends:+ haddock >=2.7.2 && <2.9.3+ if os(windows)- build-depends: Win32 >=2.2.0.0 && <2.4- 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.8+ build-depends:+ unix >=2.3.1.0 && <2.8 if flag(network-uri)- build-depends: network-uri >=2.6 && <2.7, network >= 2.6 && <2.7+ build-depends:+ network-uri >=2.6 && <2.7,+ network >=2.6 && <2.7 else- build-depends: network >=2.2 && <2.6-- exposed-modules: IDE.Utils.GHCUtils IDE.Utils.Utils IDE.Utils.Tool- IDE.Utils.FileUtils IDE.Core.CTypes IDE.Core.Serializable IDE.StrippedPrefs- IDE.Utils.Server IDE.Metainfo.PackageCollector IDE.Utils.VersionUtils- IDE.Metainfo.WorkspaceCollector IDE.Metainfo.SourceDB- IDE.HeaderParser IDE.Metainfo.SourceCollectorH- exposed: True- buildable: True- default-extensions: CPP+ build-depends:+ network >=2.2 && <2.6+ if !impl(ghcjs)+ build-depends:+ ghc >=7.0.4 && <8.3+ exposed-modules:+ IDE.Utils.CabalPlan+ IDE.Utils.CabalProject+ IDE.Utils.GHCUtils+ IDE.Utils.Utils+ IDE.Utils.Tool+ IDE.Utils.FileUtils+ IDE.Core.CTypes+ IDE.Core.Serializable+ IDE.StrippedPrefs+ IDE.Utils.Server+ IDE.Metainfo.PackageCollector+ IDE.Utils.VersionUtils+ IDE.Metainfo.WorkspaceCollector+ IDE.Metainfo.SourceDB+ IDE.HeaderParser+ IDE.Metainfo.SourceCollectorH+ build-depends:+ Cabal >=1.10.2.0 && <2.1,+ base >=4.0.0.0 && <4.11,+ binary >=0.5.0.0 && <0.9,+ 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.4,+ filepath >=1.1.0.1 && <1.5,+ ltk >=0.16.0.0 && <0.17,+ parsec >=3.0.0.0 && <3.2,+ pretty >=1.0.1.0 && <1.2,+ time >=1.1 && <1.9,+ deepseq >=1.1 && <1.5,+ hslogger >=1.0.7 && <1.3,+ conduit >=1.0.8 && <1.3,+ conduit-extra >=1.0.0.1 && <1.2,+ resourcet -any,+ attoparsec >=0.10.0.3 && <0.14,+ transformers >=0.2.2.0 && <0.6,+ strict >=0.3.2 && <0.4,+ text >=0.11.3.1 && <1.3,+ HTTP >=4000.1.2 && <4000.4,+ process >=1.1 && <1.7,+ base-compat >=0.9.0 && <0.10,+ aeson >=0.11.2.0 && <1.3+ default-language: Haskell2010 hs-source-dirs: src other-modules: IDE.Metainfo.InterfaceCollector Paths_leksah_server- ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans+ ghc-options: -Wall -ferror-spans executable leksah-server- default-language: Haskell98- build-depends: Cabal >=1.10.2.0 && <1.23, base >= 4.0.0.0 && <4.9, 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.5, ghc >=7.0.4 && <7.11,- ltk >=0.15.0.1 && <0.16, parsec >=3.0.0.0 && <3.2,- pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.6, deepseq >=1.1 && <1.5,- hslogger >= 1.0.7 && <1.3, conduit >= 1.0.8 && <1.3,- conduit-extra >=1.0.0.1 && <1.2, resourcet,- attoparsec >=0.10.0.3 && <0.14,- transformers >=0.2.2.0 && <0.5, strict >=0.3.2 && <0.4, text >=0.11.3.1 && <1.3,- HTTP >=4000.1.2 && <4000.4, process >= 1.1 && <1.3, leksah-server ==0.15.2.0- if (impl(ghc >= 7.10))- build-depends: haddock-api >=2.16 && <2.17, haddock-library >=1.2.0 && <1.3, bin-package-db- else- if (impl(ghc >= 7.8))- build-depends: haddock-api >= 2.7.2 && <2.16- else- if (impl(ghc >= 7.6))- build-depends: haddock >= 2.7.2 && <2.14++ if !impl(ghcjs)+ if impl(ghc >=8.2)+ build-depends:+ haddock-api >=2.18.1 && <2.19,+ haddock-library >=1.4.1 && <1.5,+ ghc-boot >=8.2.1 && <8.3 else- if (impl(ghc >= 7.4.2))- build-depends: haddock >= 2.11.1 && <2.12- else- if (impl(ghc >= 7.4))- build-depends: haddock >= 2.7.2 && <2.11++ if impl(ghc >=8.0)+ build-depends:+ haddock-api >=2.17.2 && <2.18,+ haddock-library >=1.4.1 && <1.5,+ ghc-boot >=8.0.1 && <8.1 else- if (impl(ghc >= 7.2))- build-depends: haddock >= 2.7.2 && <2.10- else- build-depends: haddock >= 2.7.2 && <2.9.3 + if impl(ghc >=7.10)+ build-depends:+ haddock-api >=2.16 && <2.17,+ haddock-library >=1.2.0 && <1.3,+ bin-package-db -any+ else++ if impl(ghc >=7.8)+ build-depends:+ haddock-api >=2.7.2 && <2.16+ else++ 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.4)+ build-depends:+ haddock >=2.7.2 && <2.11+ else++ if impl(ghc >=7.2)+ build-depends:+ haddock >=2.7.2 && <2.10+ else+ build-depends:+ haddock >=2.7.2 && <2.9.3+ if os(windows)- build-depends: Win32 >=2.2.0.0 && <2.4- 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.8+ build-depends:+ unix >=2.3.1.0 && <2.8 if flag(network-uri)- build-depends: network-uri >=2.6 && <2.7, network >= 2.6 && <2.7+ build-depends:+ network-uri >=2.6 && <2.7,+ network >=2.6 && <2.7 else- build-depends: network >=2.2 && <2.6+ build-depends:+ network >=2.2 && <2.6 if os(osx) ghc-options: -optl-headerpad_max_install_names - main-is: Collector.hs- buildable: True- default-extensions: CPP- hs-source-dirs: main- if flag(threaded) ghc-options: -threaded - ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -ferror-spans+ if !impl(ghcjs)+ build-depends:+ ghc >=7.0.4 && <8.3 -executable leksahecho- default-language: Haskell98- main-is: LeksahEcho.hs- buildable: True- default-extensions: CPP+ main-is: Collector.hs+ build-depends:+ Cabal >=1.10.2.0 && <2.1,+ base >=4.0.0.0 && <4.11,+ binary >=0.5.0.0 && <0.9,+ 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.4,+ filepath >=1.1.0.1 && <1.5,+ ltk >=0.16.0.0 && <0.17,+ parsec >=3.0.0.0 && <3.2,+ pretty >=1.0.1.0 && <1.2,+ time >=1.1 && <1.9,+ deepseq >=1.1 && <1.5,+ hslogger >=1.0.7 && <1.3,+ conduit >=1.0.8 && <1.3,+ conduit-extra >=1.0.0.1 && <1.2,+ resourcet -any,+ attoparsec >=0.10.0.3 && <0.14,+ transformers >=0.2.2.0 && <0.6,+ strict >=0.3.2 && <0.4,+ text >=0.11.3.1 && <1.3,+ HTTP >=4000.1.2 && <4000.4,+ process >=1.1 && <1.7,+ leksah-server,+ base-compat >=0.9.0 && <0.10+ default-language: Haskell2010 hs-source-dirs: main- build-depends: base >= 4.0.0.0 && <4.9, hslogger >= 1.0.7 && <1.3, deepseq >=1.1 && <1.5,- bytestring >=0.9.0.1 && <0.11, conduit >= 1.0.8 && <1.3,- conduit-extra >=1.0.0.1 && <1.2, resourcet,- attoparsec >=0.10.0.3 && <0.14,- transformers >=0.2.2.0 && <0.5, text >=0.11.3.1 && <1.3,- process >= 1.1 && <1.3, leksah-server ==0.15.2.0+ ghc-options: -rtsopts -Wall -ferror-spans +executable leksahecho+ if !os(windows)- build-depends: unix >=2.3.1.0 && <2.8+ build-depends:+ unix >=2.3.1.0 && <2.8 if os(osx) ghc-options: -optl-headerpad_max_install_names if flag(threaded) ghc-options: -threaded-- ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans+ main-is: LeksahEcho.hs+ build-depends:+ base >=4.0.0.0 && <4.11,+ hslogger >=1.0.7 && <1.3,+ deepseq >=1.1 && <1.5,+ bytestring >=0.9.0.1 && <0.11,+ conduit >=1.0.8 && <1.3,+ conduit-extra >=1.0.0.1 && <1.2,+ resourcet -any,+ attoparsec >=0.10.0.3 && <0.14,+ transformers >=0.2.2.0 && <0.6,+ text >=0.11.3.1 && <1.3,+ process >=1.1 && <1.7,+ leksah-server+ default-language: Haskell2010+ hs-source-dirs: main+ ghc-options: -Wall -ferror-spans executable leksahtrue- default-language: Haskell98 main-is: LeksahTrue.hs- buildable: True+ build-depends:+ base >=4.0.0.0 && <4.11+ default-language: Haskell2010 hs-source-dirs: main- build-depends: base >= 4.0.0.0 && <4.9 test-suite test-tool- default-language: Haskell98- type: exitcode-stdio-1.0+ type: exitcode-stdio-1.0+ main-is: TestTool.hs+ if !impl(ghcjs)+ build-depends:+ doctest >=0.11.0 && <0.12+ build-depends:+ base >=4.0.0.0 && <4.11,+ hslogger >=1.0.7 && <1.3,+ leksah-server,+ HUnit >=1.2 && <1.7,+ transformers >=0.2.2.0 && <0.6,+ conduit >=1.0.8 && <1.3,+ conduit-extra >=1.0.0.1 && <1.2,+ resourcet -any,+ process >=1.1 && <1.7,+ directory >=1.0.0.2 && <1.4,+ filepath >=1.1.0.1 && <1.5,+ text >=0.11.3.1 && <1.3+ default-language: Haskell2010 hs-source-dirs: tests- main-is: TestTool.hs- build-depends: base >= 4.0.0.0 && <4.9, hslogger >= 1.0.7 && <1.3,- leksah-server == 0.15.2.0,- HUnit >=1.2 && <1.4, transformers >=0.2.2.0 && <0.5, conduit >= 1.0.8 && <1.3,- conduit-extra >=1.0.0.1 && <1.2, resourcet,- process >= 1.1 && <1.3-+ ghc-options: -Wall -ferror-spans
main/Collector.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}@@ -22,11 +23,12 @@ , collectPackage ) where -import Control.Applicative-import Prelude+import Prelude ()+import Prelude.Compat import System.Console.GetOpt (ArgDescr(..), usageInfo, ArgOrder(..), getOpt, OptDescr(..)) import System.Environment (getArgs)+import System.FilePath ((</>), (<.>)) import Control.Monad (when, forM) import Data.Version (showVersion) import IDE.Utils.FileUtils@@ -35,13 +37,7 @@ import IDE.StrippedPrefs import IDE.Metainfo.WorkspaceCollector import Data.Maybe(catMaybes, fromJust, mapMaybe, isJust)-#if MIN_VERSION_ghc(7,8,0)-#else-import Prelude hiding(catch)-#endif-import Control.Monad (liftM) import qualified Data.Set as Set (member)-import qualified Data.Map as Map (toList, fromListWith) import IDE.Core.CTypes hiding (Extension) import IDE.Metainfo.SourceDB (buildSourceForPackageDB, getDataDir, version) import Data.Time@@ -60,7 +56,8 @@ import Data.IORef import Control.Concurrent (MVar,putMVar) import IDE.Metainfo.PackageCollector(collectPackage)-import Data.List (delete)+import Data.List (nub, delete, sortBy)+import Data.Ord (comparing) import System.Directory (removeFile, doesFileExist, removeDirectoryRecursive, doesDirectoryExist)@@ -69,7 +66,6 @@ import qualified Data.Text as T (strip, pack, unpack) import Data.Text (Text) import Data.Monoid ((<>))-import Distribution.Package (PackageIdentifier) -- -------------------------------------------------------------------- -- Command line options@@ -91,6 +87,7 @@ | LogFile Text | Forever | EndWithLast+ | PackageDir FilePath deriving (Show,Eq) options :: [OptDescr Flag]@@ -119,6 +116,8 @@ "Don't end the server when last connection ends" , Option ['c'] ["endWithLast"] (NoArg EndWithLast) "End the server when last connection ends"+ , Option ['p'] ["packageDir"] (ReqArg (PackageDir) "PackageDir")+ "Package directory to include in collection (like a workspace package)" ] @@ -139,7 +138,7 @@ main = withSocketsDo $ catch inner handler where handler (e :: SomeException) = do- putStrLn $ "leksah-server: " ++ (show e)+ putStrLn $ "leksah-server: " ++ show e errorM "leksah-server" (show e) return () inner = do@@ -159,11 +158,11 @@ let logFile = case logFile' of [] -> Nothing h:_ -> Just h- updateGlobalLogger rootLoggerName (\ l -> setLevel verbosity l)+ updateGlobalLogger rootLoggerName (setLevel verbosity) when (isJust logFile) $ do handler' <- fileHandler (T.unpack $ fromJust logFile) verbosity- updateGlobalLogger rootLoggerName (\ l -> addHandler handler' l)- infoM "leksah-server" $ "***server start"+ updateGlobalLogger rootLoggerName (addHandler handler')+ infoM "leksah-server" "***server start" debugM "leksah-server" $ "args: " ++ show args dataDir <- getDataDir prefsPath <- getConfigFilePathForLoad strippedPreferencesFilename Nothing dataDir@@ -186,15 +185,14 @@ let debug = elem Debug o let forever = elem Forever o let endWithLast = elem EndWithLast o- let newPrefs = if forever && not endWithLast- then prefs{endWithLastConn = False}- else if not forever && endWithLast- then prefs{endWithLastConn = True}- else prefs+ let newPrefs+ | forever && not endWithLast = prefs{endWithLastConn = False}+ | not forever && endWithLast = prefs{endWithLastConn = True}+ | otherwise = prefs if elem CollectSystem o then do debugM "leksah-server" "collectSystem"- collectSystem prefs debug rebuild sources []+ collectSystem prefs debug rebuild sources =<< getPackageDBs [d | PackageDir d <- o] else case servers of (Nothing:_) -> do@@ -221,22 +219,21 @@ doCommands' :: Prefs -> IORef [Handle] -> (Handle, t1, t2) -> MVar () -> IO () doCommands' prefs connRef (h,n,p) mvar = do- debugM "leksah-server" $ "***wait"- mbLine <- catch (liftM Just (hGetLine h))+ debugM "leksah-server" "***wait"+ mbLine <- catch (Just <$> hGetLine h) (\ (_e :: SomeException) -> do- infoM "leksah-server" $ "***lost connection"+ infoM "leksah-server" "***lost connection" hClose h atomicModifyIORef connRef (\ list -> (delete h list,())) handles <- readIORef connRef case handles of [] -> do- if (endWithLastConn prefs)+ if endWithLastConn prefs then do- infoM "leksah-server" $ "***lost last connection - exiting"+ infoM "leksah-server" "***lost last connection - exiting" -- we're waiting on that mvar before exiting putMVar mvar ()- else do- infoM "leksah-server" $ "***lost last connection - waiting"+ else infoM "leksah-server" "***lost last connection - waiting" return Nothing _ -> return Nothing) case mbLine of@@ -280,20 +277,25 @@ when exists' (removeFile reportPath) return () knownPackages <- findKnownPackages collectorPath+ libDir <- getSysLibDir VERSION_ghc debugM "leksah-server" $ "collectSystem knownPackages= " ++ show knownPackages- packageInfos <- concat <$> forM dbLists (\dbs -> inGhcIO [] [] dbs $ \ _ -> map (,dbs) <$> getInstalledPackageInfos)+ packageInfos <- concat <$> forM dbLists (\dbs -> inGhcIO libDir [] [] dbs $ \ _ -> map (,dbs) <$> getInstalledPackageInfos) debugM "leksah-server" $ "collectSystem packageInfos= " ++ show (map (packId . getThisPackage . fst) packageInfos)- let newPackages = filter (\pi -> not $ Set.member (packageIdentifierToString . packId . getThisPackage $ fst pi) knownPackages)+ let pkgId = packageIdentifierToString . packId . getThisPackage+ newPackages = sortBy (comparing (pkgId. fst)) . nub $+ filter (\pi' -> not $ Set.member (pkgId $ fst pi') knownPackages) packageInfos if null newPackages- then do- infoM "leksah-server" "Metadata collector has nothing to do"+ then infoM "leksah-server" "Metadata collector has nothing to do" else do when findSources $ liftIO $ buildSourceForPackageDB prefs infoM "leksah-server" "update_toolbar 0.0"- stats <- mapM (collectPackage writeAscii prefs (length newPackages))- (zip newPackages [1 .. length newPackages])- writeStats stats+ stats <- forM (zip newPackages [1 .. length newPackages]) $ \(package, n) -> do+ let pid = T.unpack . pkgId $ fst package+ liftIO (doesFileExist $ collectorPath </> pid <.> leksahMetadataPathFileExtension) >>= \case+ True -> debugM "leksah-server" ("Already created metadata for " <> pid) >> return Nothing+ False -> Just <$> collectPackage writeAscii prefs (length newPackages) (package, n)+ writeStats $ catMaybes stats infoM "leksah-server" "Metadata collection has finished" writeStats :: [PackageCollectStats] -> IO ()@@ -317,8 +319,7 @@ packagesRetreived = length (filter retrieved stats) modulesTotal' = sum (mapMaybe modulesTotal stats) modulesWithSource = sum (mapMaybe modulesTotal (filter withSource stats))- percentageWithSource = (fromIntegral modulesWithSource) * 100.0 /- (fromIntegral modulesTotal')+ percentageWithSource = fromIntegral modulesWithSource * 100.0 / fromIntegral modulesTotal' details = foldr detail "" (filter (isJust . mbError) stats) detail stat string = string <> "\n" <> packageString stat <> " " <> (T.strip . fromJust $ mbError stat) packs = foldr (\stat string -> string <> packageString stat <> " ")
main/LeksahEcho.hs view
@@ -17,7 +17,7 @@ ) where import System.Environment (getArgs)-import IDE.Utils.VersionUtils (getHaddockVersion, getGhcVersion, getGhcInfo)+import IDE.Utils.VersionUtils (getHaddockVersion, getDefaultGhcVersion, getGhcInfo) import qualified Data.Text as T (unpack) import Control.Applicative import Prelude@@ -29,10 +29,10 @@ if elem "--version" args then putStrLn =<< T.unpack <$> getHaddockVersion else if elem "--ghc-version" args- then putStrLn =<< getGhcVersion+ then putStrLn =<< getDefaultGhcVersion else if elem "--info" args- then putStrLn =<< T.unpack <$> getGhcInfo+ then putStrLn =<< T.unpack <$> (getGhcInfo =<< getDefaultGhcVersion) else if elem "--numeric-version" args- then putStrLn =<< getGhcVersion+ then putStrLn =<< getDefaultGhcVersion else putStrLn $ unwords args
src/IDE/Core/CTypes.hs view
@@ -72,8 +72,8 @@ ) where -import Control.Applicative ((<$>))-import Prelude+import Prelude ()+import Prelude.Compat import Data.Typeable (Typeable) import Data.Map (Map) import Data.Set (Set)@@ -99,7 +99,15 @@ import Data.Char (isAlpha) import Control.DeepSeq (NFData(..)) import PackageConfig (PackageConfig)-#if MIN_VERSION_ghc(7,10,0)+#if MIN_VERSION_ghc(8,0,0)+#if MIN_VERSION_ghc(8,2,0)+import Module (InstalledUnitId)+#else+import Module (UnitId)+#endif+import PackageConfig (sourcePackageIdString, unitId)+import Data.Maybe (fromJust)+#elif MIN_VERSION_ghc(7,10,0) import Module (PackageKey) import PackageConfig (sourcePackageIdString, packageKey) import Data.Maybe (fromJust)@@ -121,7 +129,7 @@ -- leksahVersion, configDirName :: FilePath-leksahVersion = "0.15"+leksahVersion = "0.16" configDirName = ".leksah-" <> leksahVersion metadataVersion :: Integer@@ -129,15 +137,22 @@ data PackageIdAndKey = PackageIdAndKey { packId :: PackageIdentifier-#if MIN_VERSION_ghc(7,10,0)+#if MIN_VERSION_ghc(8,2,0)+ , packUnitId :: InstalledUnitId+#elif MIN_VERSION_ghc(8,0,0)+ , packUnitId :: UnitId+#elif MIN_VERSION_ghc(7,10,0) , packKey :: PackageKey #endif } getThisPackage :: PackageConfig -> PackageIdAndKey getThisPackage p = PackageIdAndKey-#if MIN_VERSION_ghc(7,10,0)+#if MIN_VERSION_ghc(8,0,0) (fromJust . simpleParse $ sourcePackageIdString p)+ (unitId p)+#elif MIN_VERSION_ghc(7,10,0)+ (fromJust . simpleParse $ sourcePackageIdString p) (packageKey p) #else (IPI.sourcePackageId p)@@ -331,11 +346,12 @@ | ModNameDescr | QualModNameDescr | ErrorDescr+ | PatternSynonymDescr --the descrName is the type Konstructor? deriving (Show,Read,Eq,Ord,Typeable) data DescrType = Variable | Field | Constructor | Data | Type | Newtype- | Class | Method | Instance | Keyword | Extension | ModName | QualModName | Error+ | Class | Method | Instance | Keyword | Extension | ModName | QualModName | Error | PatternSynonym deriving (Show, Eq, Ord, Bounded, Enum, Read) instance Default DescrType where@@ -364,6 +380,7 @@ descrType ModNameDescr = ModName descrType QualModNameDescr = QualModName descrType ErrorDescr = Error+descrType PatternSynonymDescr = PatternSynonym data PackModule = PM { pack :: PackageIdentifier , modu :: ModuleName}@@ -626,8 +643,10 @@ rnf pd = rnf (pack pd) `seq` rnf (modu pd) +#if !MIN_VERSION_Cabal(2,0,0) instance NFData ModuleName where rnf = rnf . components+#endif #if !MIN_VERSION_ghc(7,7,0) instance NFData PackageName where
src/IDE/Core/Serializable.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -27,14 +28,28 @@ import Control.Monad (liftM) import Data.Maybe (fromJust) import Data.Binary.Shared (BinaryShared(..))-import Distribution.Package (PackageName(..),PackageIdentifier(..))-import Data.Version (Version(..))+#if MIN_VERSION_Cabal(2,0,0)+import Distribution.Package (PackageName, unPackageName, mkPackageName, PackageIdentifier(..))+import Distribution.Version (Version, versionNumbers, mkVersion)+#else+import Distribution.Package (PackageName(..), unPackageName, PackageIdentifier(..))+import Distribution.Version (Version(..))+#endif import Distribution.ModuleName (ModuleName) import IDE.Core.CTypes import Data.Text (Text) import qualified Data.Text as T (pack, unpack) +#if !MIN_VERSION_Cabal(2,0,0)+versionNumbers :: Version -> [Int]+versionNumbers = versionBranch+mkPackageName :: String -> PackageName+mkPackageName = PackageName+mkVersion :: [Int] -> Version+mkVersion = (`Version` [])+#endif+ ----------------------------------------------------------- instance BinaryShared Text where@@ -62,13 +77,13 @@ return (PackageIdentifier name' version')) instance BinaryShared Version where- put = putShared (\ (Version branch' tags') -> do- put branch'- put tags')+ put = putShared (\ v -> do+ put (versionNumbers v)+ put ([] :: [String])) -- Tags used to go here get = getShared (do branch' <- get- tags' <- get- return (Version branch' tags'))+ (_ :: [String]) <- get+ return (mkVersion branch')) instance BinaryShared PackageDescr where put = putShared (\ (PackageDescr packagePD' exposedModulesPD' buildDependsPD'@@ -171,6 +186,8 @@ = put (13:: Int) put ErrorDescr = put (14:: Int)+ put PatternSynonymDescr+ = put (15:: Int) get = do (typeHint :: Int) <- get case typeHint of@@ -205,6 +222,7 @@ 12 -> return ModNameDescr 13 -> return QualModNameDescr 14 -> return ErrorDescr+ 15 -> return PatternSynonymDescr _ -> error "Impossible in Binary SpDescr get" instance BinaryShared SimpleDescr where@@ -241,8 +259,8 @@ get = liftM (fromJust . simpleParse) get instance BinaryShared PackageName where- put (PackageName pn) = put pn- get = liftM PackageName get+ put pn = put (unPackageName pn)+ get = liftM mkPackageName get
src/IDE/HeaderParser.hs view
@@ -26,6 +26,11 @@ import FastString(unpackFS) import IDE.Utils.GHCUtils import Data.Maybe (mapMaybe)+#if MIN_VERSION_ghc(8,2,0)+import BasicTypes (StringLiteral(..), SourceText(..))+#elif MIN_VERSION_ghc(8,0,0)+import BasicTypes (StringLiteral(..))+#endif #if MIN_VERSION_ghc(7,4,1) import Outputable(pprPrefixOcc, ppr) #else@@ -48,6 +53,11 @@ showSDocUnqual _ = O.showSDocUnqual #endif +#if !MIN_VERSION_ghc(8,2,0)+ieLWrappedName :: a -> a+ieLWrappedName = id+#endif+ #if MIN_VERSION_ghc(7,10,0) unLoc710 :: GenLocated l e -> e unLoc710 = unLoc@@ -56,6 +66,14 @@ unLoc710 = id #endif +#if MIN_VERSION_ghc(8,2,0)+unLoc82 :: GenLocated l e -> e+unLoc82 = unLoc+#else+unLoc82 :: a -> a+unLoc82 = id+#endif+ showRdrName :: DynFlags -> RdrName -> String showRdrName dflags r = showSDoc dflags (ppr r) @@ -97,11 +115,17 @@ where modName = moduleNameString $ unLoc $ ideclName importDecl pkgQual = case ideclPkgQual importDecl of- Nothing -> Nothing+#if MIN_VERSION_ghc(8,2,0)+ Just StringLiteral { sl_st = SourceText s } -> Just s+#elif MIN_VERSION_ghc(8,0,0)+ Just fs -> Just (sl_st fs)+#else Just fs -> Just (unpackFS fs)+#endif+ _ -> Nothing impAs = case ideclAs importDecl of Nothing -> Nothing- Just mn -> Just (moduleNameString mn)+ Just mn -> Just (moduleNameString $ unLoc82 mn) specs = case ideclHiding importDecl of Nothing -> Nothing Just (hide, list) -> Just (ImportSpecList hide (mapMaybe (transformEntity dflags) (unLoc710 list)))@@ -112,10 +136,14 @@ #else transformEntity dflags (L _ (IEVar name)) = Just (IVar (T.pack $ showSDoc dflags (pprHsVar name))) #endif-transformEntity dflags (L _ (IEThingAbs name)) = Just (IAbs (T.pack . showRdrName dflags $ unLoc710 name))-transformEntity dflags (L _ (IEThingAll name)) = Just (IThingAll (T.pack . showRdrName dflags $ unLoc710 name))+transformEntity dflags (L _ (IEThingAbs name)) = Just (IAbs (T.pack . showRdrName dflags . unLoc710 $ ieLWrappedName name))+transformEntity dflags (L _ (IEThingAll name)) = Just (IThingAll (T.pack . showRdrName dflags . unLoc710 $ ieLWrappedName name))+#if MIN_VERSION_ghc(8,0,0)+transformEntity dflags (L _ (IEThingWith name _ list _)) = Just (IThingWith (T.pack . showRdrName dflags . unLoc710 $ ieLWrappedName name)+#else transformEntity dflags (L _ (IEThingWith name list)) = Just (IThingWith (T.pack . showRdrName dflags $ unLoc710 name)- (map (T.pack . showRdrName dflags . unLoc710) list))+#endif+ (map (T.pack . showRdrName dflags . unLoc710 . ieLWrappedName) list)) transformEntity _ _ = Nothing #if MIN_VERSION_ghc(7,2,0)
src/IDE/Metainfo/InterfaceCollector.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}@@ -38,8 +39,11 @@ import HscTypes hiding (liftIO) import qualified HscTypes as Hs (liftIO) #endif-#if MIN_VERSION_ghc(7,3,0)+#if MIN_VERSION_ghc(8,0,0) import Avail+import TysWiredIn ( )+#elif MIN_VERSION_ghc(7,3,0)+import Avail import TysWiredIn ( eqTyConName ) #endif import LoadIface@@ -60,7 +64,11 @@ import Data.Maybe import qualified Data.Set as Set import Data.Set (Set)-#if MIN_VERSION_ghc(7,10,0)+#if MIN_VERSION_ghc(8,2,0)+import ToIface (toIfaceTyCon_name)+import FieldLabel (flSelector)+import GHC.PackageDb (exposedModules, hiddenModules)+#elif MIN_VERSION_ghc(7,10,0) import GHC.PackageDb (exposedModules, hiddenModules, exposedName) #else import PackageConfig (mkPackageId)@@ -75,11 +83,28 @@ import Data.ByteString.Char8 (ByteString) import TcRnMonad (initTcRnIf) import IDE.Utils.GHCUtils+import IDE.Utils.FileUtils (getSysLibDir) import Control.DeepSeq(deepseq) import Data.Text (Text) import qualified Data.Text as T (pack) import System.Log.Logger (debugM) +#if MIN_VERSION_ghc(8,2,0)+exposedName :: (Module.ModuleName, Maybe Module.Module) -> Module.ModuleName+exposedName = fst+nameOccName82 :: Name -> OccName+nameOccName82 = nameOccName+#else+mkPackageName :: String -> PackageName+mkPackageName = PackageName+nameOccName82 :: OccName -> OccName+nameOccName82 = id+flSelector :: OccName -> OccName+flSelector = id+ifConName :: IfaceConDecl -> OccName+ifConName = ifConOcc+#endif+ #if !MIN_VERSION_ghc(7,6,0) showSDoc :: DynFlags -> SDoc -> Text showSDoc _ = O.showSDoc@@ -88,7 +113,9 @@ #endif collectPackageFromHI :: PackageConfig -> [FilePath] -> IO PackageDescr-collectPackageFromHI packageConfig dbs = inGhcIO [] [] dbs $ \ dflags -> do+collectPackageFromHI packageConfig dbs = do+ libDir <- getSysLibDir VERSION_ghc+ inGhcIO libDir [] [] dbs $ \ dflags -> do let pIdAndKey = getThisPackage packageConfig Hs.liftIO . debugM "leksah-server" $ "collectPackageFromHI" session <- getSession@@ -112,20 +139,27 @@ getIFaceInfos :: PackageIdAndKey -> [Module.ModuleName] -> HscEnv -> Ghc [(ModIface, FilePath)] getIFaceInfos p modules _session = do let pid = packId p- makeMod = mkModule-#if MIN_VERSION_ghc(7,10,0)- (packKey p)+#if MIN_VERSION_ghc(8,2,0)+ makeMod = mkModule (DefiniteUnitId (DefUnitId (packUnitId p)))+ makeInstMod = InstalledModule (packUnitId p)+#elif MIN_VERSION_ghc(8,0,0)+ makeMod = mkModule (packUnitId p)+#elif MIN_VERSION_ghc(7,10,0)+ makeMod = mkModule (packKey p) #else- (mkPackageId pid)+ makeMod = mkModule (mkPackageId pid) #endif- isBase = pkgName pid == PackageName "base"+ isBase = pkgName pid == mkPackageName "base" ifaces = mapM (\ mn -> findAndReadIface empty+#if MIN_VERSION_ghc(8,2,0)+ (makeInstMod mn)+#endif (if isBase then mkBaseModule_ mn else makeMod mn) False) modules hscEnv <- getSession- let gblEnv = IfGblEnv { if_rec_types = Nothing }+ let gblEnv = IfGblEnv { if_rec_types = Nothing, if_doc = empty } maybes <- Hs.liftIO $ initTcRnIf 'i' hscEnv gblEnv () ifaces let res = mapMaybe handleErr maybes return res@@ -135,6 +169,9 @@ ------------------------------------------------------------------------- +converModuleName :: Module.ModuleName -> ModuleName+converModuleName = fromJust . simpleParse . moduleNameString+ extractInfo :: DynFlags -> [(ModIface, FilePath)] -> [(ModIface, FilePath)] -> PackageIdAndKey -> [PackageIdentifier] -> PackageDescr extractInfo dflags ifacesExp ifacesHid pid buildDepends =@@ -147,52 +184,40 @@ , pdBuildDepends = buildDepends , pdMbSourcePath = Nothing} -extractExportedDescrH :: DynFlags -> PackageIdAndKey -> ModIface -> [Descr]+extractExportedDescrH :: DynFlags -> PackageIdAndKey -> ModIface -> [((ModuleName, OccName), Descr)] extractExportedDescrH dflags pid iface =- let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface)+ let mid = converModuleName . moduleName $ mi_module iface exportedNames = Set.fromList-#if MIN_VERSION_Cabal(1,11,0)- $ map (occNameString . nameOccName)+ $ map nameOccName $ concatMap availNames $ mi_exports iface-#else- $ map occNameString- $ concatMap availNames- $ concatMap snd (mi_exports iface)-#endif- exportedDecls = filter (\ ifdecl -> occNameString (ifName ifdecl) `Set.member` exportedNames)+ exportedDecls = filter (\ ifdecl -> nameOccName82 (ifName ifdecl) `Set.member` exportedNames) (map snd (mi_decls iface))- in concatMap (extractIdentifierDescr dflags pid [mid]) exportedDecls+ in concatMap (extractIdentifierDescr dflags pid mid) exportedDecls extractExportedDescrR :: DynFlags -> PackageIdAndKey- -> [Descr]+ -> [((ModuleName, OccName), Descr)] -> ModIface -> ModuleDescr extractExportedDescrR dflags pid hidden iface =- let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface)- exportedNames = Set.fromList . map T.pack-#if MIN_VERSION_Cabal(1,11,0)- $ map (occNameString . nameOccName)+ let mid = converModuleName . moduleName $ mi_module iface+ exportedNames = Set.fromList+ $ map (\n -> (converModuleName . moduleName $ nameModule n, nameOccName n)) $ concatMap availNames $ mi_exports iface-#else- $ map occNameString- $ concatMap availNames- $ concatMap snd (mi_exports iface)-#endif- exportedDecls = filter (\ ifdecl -> (T.pack . occNameString $ ifName ifdecl)+ exportedDecls = filter (\ ifdecl -> (converModuleName . moduleName $ mi_module iface, nameOccName82 (ifName ifdecl)) `Set.member` exportedNames) (map snd (mi_decls iface))- ownDecls = concatMap (extractIdentifierDescr dflags pid [mid]) exportedDecls- otherDecls = exportedNames `Set.difference` Set.fromList (map dscName ownDecls)- reexported = map (Reexported . ReexportedDescr (Just (PM (packId pid) mid)))- $ filter (\k -> dscName k `Set.member` otherDecls) hidden+ ownDecls = concatMap (extractIdentifierDescr dflags pid mid) exportedDecls+ otherDecls = exportedNames `Set.difference` Set.fromList (map fst ownDecls)+ reexported = map (Reexported . ReexportedDescr (Just (PM (packId pid) mid)) . snd)+ $ filter (\k -> fst k `Set.member` otherDecls) hidden inst = concatMap (extractInstances dflags (PM (packId 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 (n, Real d) = Real $ d{dscExported' = Set.member n exportedNames} withExp _ = error "Unexpected Reexported" in ModuleDescr { mdModuleId = PM (packId pid) mid@@ -200,33 +225,30 @@ , mdReferences = uses , mdIdDescriptions = declsWithExp ++ inst ++ reexported} -extractIdentifierDescr :: DynFlags -> PackageIdAndKey -> [ModuleName] -> IfaceDecl -> [Descr]-extractIdentifierDescr dflags package modules decl- = if null modules- then []- else- let descr = RealDescr{- dscName' = T.pack . unpackFS . occNameFS $ ifName decl+extractIdentifierDescr :: DynFlags -> PackageIdAndKey -> ModuleName -> IfaceDecl -> [((ModuleName, OccName), Descr)]+extractIdentifierDescr dflags package mid decl+ = let descr = RealDescr{+ dscName' = T.pack . unpackFS . occNameFS . nameOccName82 $ ifName decl , dscMbTypeStr' = Just . BS.pack . unlines . nonEmptyLines . filterExtras . showSDocUnqual dflags $ ppr decl- , dscMbModu' = Just (PM (packId package) (last modules))+ , dscMbModu' = Just (PM (packId package) mid) , dscMbLocation' = Nothing , dscMbComment' = Nothing , dscTypeHint' = VariableDescr , dscExported' = True }- in case decl of- (IfaceId {}) -> map Real [descr]- (IfaceData {ifName=name, ifCons=ifCons'})+ in map ((mid, nameOccName82 $ ifName decl),) $ case decl of+ IfaceId{} -> [Real descr]+ IfaceData{ifName = name, ifCons = ifCons'} -> let d = case ifCons' of- IfDataTyCon _decls+ IfDataTyCon {} -> let fieldNames = concatMap (extractFields dflags) (visibleIfConDecls ifCons')- constructors' = extractConstructors dflags name (visibleIfConDecls ifCons')+ constructors' = extractConstructors dflags (nameOccName82 name) (visibleIfConDecls ifCons') in DataDescr constructors' fieldNames- IfNewTyCon _+ IfNewTyCon {} -> let fieldNames = concatMap (extractFields dflags) (visibleIfConDecls ifCons')- constructors' = extractConstructors dflags name (visibleIfConDecls ifCons')+ constructors' = extractConstructors dflags (nameOccName82 name) (visibleIfConDecls ifCons') mbField = case fieldNames of [] -> Nothing [fn] -> Just fn@@ -238,47 +260,55 @@ ++ "Newtype with not exactly one constructor" in NewtypeDescr constructor mbField #if MIN_VERSION_ghc(7,3,0)- IfAbstractTyCon _ -> DataDescr [] []+ IfAbstractTyCon {} -> DataDescr [] [] #else IfAbstractTyCon -> DataDescr [] [] #endif-#if MIN_VERSION_ghc(7,6,0)+#if MIN_VERSION_ghc(8,0,0)+#elif 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'} )+#if MIN_VERSION_ghc(8,2,0)+ IfaceClass{ifBody = IfAbstractClass}+ -> let+ classOpsID = []+ superclasses = []+ in [Real descr{dscTypeHint' = ClassDescr superclasses classOpsID}]+ IfaceClass{ifBody = IfConcreteClass{ifClassCtxt = context, ifSigs = ifSigs'}}+#elif MIN_VERSION_ghc(7,6,0)+ IfaceClass{ifCtxt = context, ifSigs = ifSigs'} #else (IfaceClass context _ _ _ _ ifSigs' _ ) #endif -> let classOpsID = map (extractClassOp dflags) ifSigs' superclasses = extractSuperClassNames context- in [Real $ descr{dscTypeHint' = ClassDescr superclasses classOpsID}]+ in [Real descr{dscTypeHint' = ClassDescr superclasses classOpsID}] #if MIN_VERSION_ghc(7,6,0)- (IfaceAxiom {})+ IfaceAxiom {} -> [Real descr] #endif #if MIN_VERSION_ghc(7,10,0)- (IfaceSynonym {})+ IfaceSynonym {} -> [Real $ descr{dscTypeHint' = TypeDescr}]- (IfaceFamily {})+ IfaceFamily {} -> [Real $ descr{dscTypeHint' = TypeDescr}] #else- (IfaceSyn {})+ IfaceSyn {} -> [Real $ descr{dscTypeHint' = TypeDescr}]- (IfaceForeign {})- -> [Real $ descr]+ IfaceForeign{}+ -> [Real descr] #endif #if MIN_VERSION_ghc(7,8,0)- (IfacePatSyn {})- -> [Real descr]+ IfacePatSyn {}+ -> [Real descr{dscTypeHint' = PatternSynonymDescr}] #endif extractConstructors :: DynFlags -> OccName -> [IfaceConDecl] -> [SimpleDescr]-extractConstructors dflags name = map (\decl -> SimpleDescr (T.pack . unpackFS $occNameFS (ifConOcc decl))+extractConstructors dflags name = map (\decl -> SimpleDescr (T.pack . unpackFS $occNameFS (nameOccName82 $ ifConName decl)) (Just (BS.pack $ filterExtras $ showSDocUnqual dflags $ #if MIN_VERSION_ghc(7,10,0) pprIfaceForAllPart (ifConExTvs decl)@@ -297,7 +327,11 @@ #else pp_res_ty decl = ppr name <+> fsep [ppr tv | (tv,_) <- ifConUnivTvs decl] #endif-#if MIN_VERSION_ghc(7,10,0)+#if MIN_VERSION_ghc(8,2,0)+ eq_ctxt decl = [IfaceTyConApp (toIfaceTyCon_name eqTyConName) (ITC_Vis (IfaceTyVar tv) (ITC_Vis ty ITC_Nil))+#elif MIN_VERSION_ghc(8,0,0)+ eq_ctxt decl = [IfaceTyConApp (IfaceTyCon eqTyConName NoIfaceTyConInfo) (ITC_Vis (IfaceTyVar tv) (ITC_Vis ty ITC_Nil))+#elif MIN_VERSION_ghc(7,10,0) eq_ctxt decl = [IfaceTyConApp (IfaceTc eqTyConName) (ITC_Type (IfaceTyVar tv) (ITC_Type ty ITC_Nil)) #elif MIN_VERSION_ghc(7,3,0) eq_ctxt decl = [IfaceTyConApp (IfaceTc eqTyConName) [(IfaceTyVar (occNameFS tv)), ty]@@ -308,7 +342,7 @@ extractFields :: DynFlags -> IfaceConDecl -> [SimpleDescr] extractFields dflags decl = map (\ (n, t) -> SimpleDescr n t Nothing Nothing True)- $ zip (map extractFieldNames (ifConFields decl))+ $ zip (map (extractFieldNames . nameOccName82 . flSelector) (ifConFields decl)) (map (extractType dflags) (ifConArgTys decl)) extractType :: DynFlags -> IfaceType -> Maybe ByteString@@ -318,7 +352,7 @@ extractFieldNames occName' = T.pack . unpackFS $occNameFS occName' extractClassOp :: DynFlags -> IfaceClassOp -> SimpleDescr-extractClassOp dflags (IfaceClassOp occName' _dm ty) = SimpleDescr (T.pack . unpackFS $occNameFS occName')+extractClassOp dflags (IfaceClassOp occName' _dm ty) = SimpleDescr (T.pack . unpackFS . occNameFS $ nameOccName82 occName') (Just (BS.pack $ showSDocUnqual dflags (ppr ty))) Nothing Nothing True @@ -353,15 +387,18 @@ extractUsages :: DynFlags -> Usage -> Maybe (ModuleName, Set Text)-extractUsages _ (UsagePackageModule {usg_mod = usg_mod'}) =+extractUsages _ UsagePackageModule {usg_mod = usg_mod'} = let name = (fromJust . simpleParse . moduleNameString) (moduleName usg_mod') in Just (name, Set.fromList [])-extractUsages dflags (UsageHomeModule {usg_mod_name = usg_mod_name', usg_entities = usg_entities'}) =+extractUsages dflags UsageHomeModule {usg_mod_name = usg_mod_name', usg_entities = usg_entities'} = let name = (fromJust . simpleParse . moduleNameString) usg_mod_name' ids = map (T.pack . 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+#if MIN_VERSION_ghc(8,2,0)+extractUsages _ UsageMergedRequirement {} = Nothing #endif filterExtras, filterExtras' :: String -> String
src/IDE/Metainfo/PackageCollector.hs view
@@ -30,10 +30,15 @@ import System.Log.Logger (errorM, debugM, infoM) import IDE.Metainfo.InterfaceCollector (collectPackageFromHI) import IDE.Core.CTypes- (metadataVersion, PackageDescr(..), leksahVersion,- packageIdentifierToString, getThisPackage, packId)+ (dscTypeHint, descrType, dscName, modu, sdExported, sdComment,+ sdLocation, sdType, sdName, SimpleDescr(..), TypeDescr(..),+ dsrDescr, dsrMbModu, ReexportedDescr(..), Descr(..), dscExported',+ dscTypeHint', dscMbComment', dscMbLocation', dscMbModu',+ dscMbTypeStr', dscName', RealDescr(..), Descr, metadataVersion,+ PackageDescr(..), leksahVersion, packageIdentifierToString,+ getThisPackage, packId, ModuleDescr(..)) import IDE.Utils.FileUtils (getCollectorPath)-import System.Directory (doesDirectoryExist, setCurrentDirectory)+import System.Directory (setCurrentDirectory) import IDE.Utils.Utils (leksahMetadataPathFileExtension, leksahMetadataSystemFileExtension)@@ -58,7 +63,9 @@ import qualified Data.ByteString as BS (writeFile, empty) import qualified Paths_leksah_server (version) import Distribution.System (buildArch, buildOS)-import Control.Monad (unless)+import qualified Data.Map as Map+ (fromListWith, fromList, keys, lookup)+import Data.List (delete, nub) collectPackage :: Bool -> Prefs -> Int -> ((PackageConfig, [FilePath]), Int) -> IO PackageCollectStats collectPackage writeAscii prefs numPackages ((packageConfig, dbs), packageIndex) = do@@ -80,12 +87,11 @@ BuildThenRetrieve -> do debugM "leksah-server" $ "Build (then retrieve) " <> T.unpack packageName <> " in " <> fpSource build fpSource >>= \case- (True, bstat) -> return bstat- (False, bstat) ->+ (Nothing, bstat) -> return bstat+ (Just packageDescrHi, bstat) -> retrieve fpSource >>= \case Just stats -> return stats Nothing -> do- packageDescrHi <- collectPackageFromHI packageConfig dbs writeExtractedPackage False packageDescrHi return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} NeverRetrieve -> do@@ -128,22 +134,22 @@ debugM "leksah-server" . T.unpack $ "collectPackage: Can't retreive = " <> packageName return Nothing - build :: FilePath -> IO (Bool, PackageCollectStats)+ build :: FilePath -> IO (Maybe PackageDescr, PackageCollectStats) build fpSource = do runCabalConfigure fpSource+ packageDescrHi <- collectPackageFromHI packageConfig dbs mbPackageDescrPair <- packageFromSource fpSource packageConfig case mbPackageDescrPair of (Just packageDescrS, bstat) -> do- writePackageDesc packageDescrS fpSource- return (True, bstat{modulesTotal = Just (length (pdModules packageDescrS))})- (Nothing, bstat) -> return (False, bstat)+ writeMerged packageDescrS packageDescrHi fpSource+ return (Nothing, bstat{modulesTotal = Just (length (pdModules packageDescrS))})+ (Nothing, bstat) -> return (Just packageDescrHi, bstat) buildOnly :: FilePath -> IO PackageCollectStats buildOnly fpSource = build fpSource >>= \case- (True, bstat) -> return bstat- (False, bstat) -> do- packageDescrHi <- collectPackageFromHI packageConfig dbs+ (Nothing, bstat) -> return bstat+ (Just packageDescrHi, bstat) -> do writeExtractedPackage False packageDescrHi return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} @@ -155,24 +161,25 @@ userAgent = concat [ "leksah-server/", display Paths_leksah_server.version , " (", display buildOS, "; ", display buildArch, ")" ]- writePackageDesc packageDescr fpSource = do- liftIO $ writeExtractedPackage writeAscii packageDescr+ writeMerged packageDescrS packageDescrHi fpSource = do+ let mergedPackageDescr = mergePackageDescrs packageDescrHi packageDescrS+ liftIO $ writeExtractedPackage writeAscii mergedPackageDescr liftIO $ writePackagePath (dropFileName fpSource) packageName runCabalConfigure fpSource = do let dirPath = dropFileName fpSource packageName' = takeBaseName fpSource- flagsFor "base" = ["-finteger-gmp2"]+ flagsFor "base" = ["-finteger-gmp", "-finteger-gmp2"]+ flagsFor ('g':'i':'-':_) = ["-f-overloaded-methods", "-f-overloaded-properties", "-f-overloaded-signals"] flagsFor _ = [] flags = flagsFor packageName'- distExists <- doesDirectoryExist $ dirPath </> "dist"- unless distExists $ do- setCurrentDirectory dirPath- E.catch (do runTool' "cabal" ["clean"] Nothing- runTool' "cabal" ("configure":flags ++ map (("--package-db"<>) .T.pack) dbs) Nothing- return ())- (\ (_e :: E.SomeException) -> do- debugM "leksah-server" "Can't configure"- return ())+ setCurrentDirectory dirPath+ E.catch (do _ <- runTool' "cabal" ["clean"] Nothing Nothing+ debugM "leksah" $ "fpSource = " <> show fpSource+ _ <- runTool' "cabal" ("configure":flags ++ map (("--package-db="<>) .T.pack) dbs) Nothing Nothing+ return ())+ (\ (_e :: E.SomeException) -> do+ debugM "leksah-server" "Can't configure"+ return ()) writeExtractedPackage :: MonadIO m => Bool -> PackageDescr -> m () writeExtractedPackage writeAscii pd = do@@ -188,4 +195,127 @@ collectorPath <- liftIO getCollectorPath let filePath = collectorPath </> T.unpack packageName <.> leksahMetadataPathFileExtension liftIO $ writeFile filePath fp++--------------Merging of .hi and .hs parsing / parsing and typechecking results++mergePackageDescrs :: PackageDescr -> PackageDescr -> PackageDescr+mergePackageDescrs packageDescrHI packageDescrS = PackageDescr {+ pdPackage = pdPackage packageDescrHI+ , pdMbSourcePath = pdMbSourcePath packageDescrS+ , pdModules = mergeModuleDescrs (pdModules packageDescrHI) (pdModules packageDescrS)+ , pdBuildDepends = pdBuildDepends packageDescrHI}++mergeModuleDescrs :: [ModuleDescr] -> [ModuleDescr] -> [ModuleDescr]+mergeModuleDescrs hiList srcList = map mergeIt allNames+ where+ mergeIt :: String -> ModuleDescr+ mergeIt str = case (Map.lookup str hiDict, Map.lookup str srcDict) of+ (Just mdhi, Nothing) -> mdhi+ (Nothing, Just mdsrc) -> mdsrc+ (Just mdhi, Just mdsrc) -> mergeModuleDescr mdhi mdsrc+ (Nothing, Nothing) -> error "Collector>>mergeModuleDescrs: impossible"+ allNames = nub $ Map.keys hiDict ++ Map.keys srcDict+ hiDict = Map.fromList $ zip ((map (display . modu . mdModuleId)) hiList) hiList+ srcDict = Map.fromList $ zip ((map (display . modu . mdModuleId)) srcList) srcList++mergeModuleDescr :: ModuleDescr -> ModuleDescr -> ModuleDescr+mergeModuleDescr hiDescr srcDescr = ModuleDescr {+ mdModuleId = mdModuleId hiDescr+ , mdMbSourcePath = mdMbSourcePath srcDescr+ , mdReferences = mdReferences hiDescr+ , mdIdDescriptions = mergeDescrs (mdIdDescriptions hiDescr) (mdIdDescriptions srcDescr)}++mergeDescrs :: [Descr] -> [Descr] -> [Descr]+mergeDescrs hiList srcList = concatMap mergeIt allNames+ where+ mergeIt :: Text -> [Descr]+ mergeIt pm = case (Map.lookup pm hiDict, Map.lookup pm srcDict) of+ (Just mdhi, Nothing) -> mdhi+ (Nothing, Just mdsrc) -> mdsrc+ (Just mdhi, Just mdsrc) -> map (\ (a,b) -> mergeDescr a b) $ makePairs mdhi mdsrc+ (Nothing, Nothing) -> error "Collector>>mergeModuleDescrs: impossible"+ allNames = nub $ Map.keys hiDict ++ Map.keys srcDict+ hiDict = Map.fromListWith (++) $ zip ((map dscName) hiList) (map (\ e -> [e]) hiList)+ srcDict = Map.fromListWith (++) $ zip ((map dscName) srcList)(map (\ e -> [e]) srcList)++makePairs :: [Descr] -> [Descr] -> [(Maybe Descr,Maybe Descr)]+makePairs (hd:tl) srcList = (Just hd, theMatching)+ : makePairs tl (case theMatching of+ Just tm -> delete tm srcList+ Nothing -> srcList)+ where+ theMatching = findMatching hd srcList+ findMatching ele (hd':tail')+ | matches ele hd' = Just hd'+ | otherwise = findMatching ele tail'+ findMatching _ele [] = Nothing+ matches :: Descr -> Descr -> Bool+ matches d1 d2 = (descrType . dscTypeHint) d1 == (descrType . dscTypeHint) d2+makePairs [] rest = map (\ a -> (Nothing, Just a)) rest++mergeDescr :: Maybe Descr -> Maybe Descr -> Descr+mergeDescr (Just descr) Nothing = descr+mergeDescr Nothing (Just descr) = descr+mergeDescr (Just (Real rdhi)) (Just (Real rdsrc)) =+ Real RealDescr {+ dscName' = dscName' rdhi+ , dscMbTypeStr' = dscMbTypeStr' rdsrc+ , dscMbModu' = dscMbModu' rdsrc+ , dscMbLocation' = dscMbLocation' rdsrc+ , dscMbComment' = dscMbComment' rdsrc+ , dscTypeHint' = mergeTypeDescr (dscTypeHint' rdhi) (dscTypeHint' rdsrc)+ , dscExported' = True+ }+mergeDescr (Just (Reexported rdhi)) (Just rdsrc) =+ Reexported $ ReexportedDescr {+ dsrMbModu = dsrMbModu rdhi+ , dsrDescr = mergeDescr (Just (dsrDescr rdhi)) (Just rdsrc)+ }+mergeDescr _ _ = error "Collector>>mergeDescr: impossible"++--mergeTypeHint :: Maybe TypeDescr -> Maybe TypeDescr -> Maybe TypeDescr+--mergeTypeHint Nothing Nothing = Nothing+--mergeTypeHint Nothing jtd = jtd+--mergeTypeHint jtd Nothing = jtd+--mergeTypeHint (Just tdhi) (Just tdhs) = Just (mergeTypeDescr tdhi tdhs)++mergeTypeDescr :: TypeDescr -> TypeDescr -> TypeDescr+mergeTypeDescr (DataDescr constrListHi fieldListHi) (DataDescr constrListSrc fieldListSrc) =+ DataDescr (mergeSimpleDescrs constrListHi constrListSrc) (mergeSimpleDescrs fieldListHi fieldListSrc)+mergeTypeDescr (NewtypeDescr constrHi mbFieldHi) (NewtypeDescr constrSrc mbFieldSrc) =+ NewtypeDescr (mergeSimpleDescr constrHi constrSrc) (mergeMbDescr mbFieldHi mbFieldSrc)+mergeTypeDescr (ClassDescr superHi methodsHi) (ClassDescr _superSrc methodsSrc) =+ ClassDescr superHi (mergeSimpleDescrs methodsHi methodsSrc)+mergeTypeDescr (InstanceDescr _bindsHi) (InstanceDescr bindsSrc) =+ InstanceDescr bindsSrc+mergeTypeDescr descrHi _ =+ descrHi++mergeSimpleDescrs :: [SimpleDescr] -> [SimpleDescr] -> [SimpleDescr]+mergeSimpleDescrs hiList srcList = map mergeIt allNames+ where+ mergeIt :: Text -> SimpleDescr+ mergeIt pm = case mergeMbDescr (Map.lookup pm hiDict) (Map.lookup pm srcDict) of+ Just mdhi -> mdhi+ Nothing -> error "Collector>>mergeSimpleDescrs: impossible"+ allNames = nub $ Map.keys hiDict ++ Map.keys srcDict+ hiDict = Map.fromList $ zip ((map sdName) hiList) hiList+ srcDict = Map.fromList $ zip ((map sdName) srcList) srcList++mergeSimpleDescr :: SimpleDescr -> SimpleDescr -> SimpleDescr+mergeSimpleDescr sdHi sdSrc = SimpleDescr {+ sdName = sdName sdHi,+ sdType = sdType sdHi,+ sdLocation = sdLocation sdSrc,+ sdComment = sdComment sdSrc,+ sdExported = sdExported sdSrc}++mergeMbDescr :: Maybe SimpleDescr -> Maybe SimpleDescr -> Maybe SimpleDescr+mergeMbDescr (Just mdhi) Nothing = Just mdhi+mergeMbDescr Nothing (Just mdsrc) = Just mdsrc+mergeMbDescr (Just mdhi) (Just mdsrc) = Just (mergeSimpleDescr mdhi mdsrc)+mergeMbDescr Nothing Nothing = Nothing+++
src/IDE/Metainfo/SourceCollectorH.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -----------------------------------------------------------------------------@@ -36,7 +37,7 @@ #else import Documentation.Haddock #endif-import Distribution.Text (simpleParse)+import Distribution.Text (simpleParse, display) #if MIN_VERSION_ghc(7,6,0) import InstEnv (ClsInst(..)) #else@@ -53,7 +54,12 @@ import PackageConfig (PackageConfig) import Distribution.Verbosity (verbose) #if MIN_VERSION_ghc(7,10,0)+#if MIN_VERSION_ghc(8,2,0)+import GHC.PackageDb (exposedModules, hiddenModules)+import Module (ModuleName, Module)+#else import GHC.PackageDb (exposedModules, hiddenModules, exposedName)+#endif import Documentation.Haddock.Types (_doc) #else import qualified Distribution.InstalledPackageInfo as IPI@@ -68,8 +74,8 @@ import qualified Control.Exception as NewException (SomeException, catch) import IDE.Utils.Tool import Control.Monad (unless)-import IDE.Utils.FileUtils (figureOutGhcOpts, myCanonicalizePath)-import Distribution.Package(PackageIdentifier)+import IDE.Utils.FileUtils (figureOutGhcOpts', myCanonicalizePath, getSysLibDir)+import Distribution.Package(PackageIdentifier, pkgName) import GHC hiding(Id,Failed,Succeeded,ModuleName) import Distribution.ModuleName (components) import System.Log.Logger (warningM, debugM)@@ -87,6 +93,11 @@ import qualified Data.Text as T (unpack, pack) import Data.Monoid ((<>)) +#if MIN_VERSION_ghc(8,2,0)+exposedName :: (ModuleName, Maybe Module) -> ModuleName+exposedName = fst+#endif+ type HsDoc a = Doc a type NDoc = HsDoc Name@@ -127,11 +138,11 @@ exists <- doesDirectoryExist fpUnpack unless exists $ createDirectory fpUnpack setCurrentDirectory fpUnpack- runTool' "cabal" ["unpack", packageName] Nothing+ _ <- runTool' "cabal" ["unpack", packageName] Nothing Nothing success <- doesDirectoryExist (fpUnpack </> packageName') if not success then return (Left "Failed to download and unpack source")- else return (Right (fpUnpack </> packageName' </> takeWhile (/= '-') packageName' <.> "cabal"))+ else return (Right (fpUnpack </> packageName' </> display (pkgName packageId) <.> "cabal")) where packageName = packageIdentifierToString packageId packageName' = T.unpack packageName@@ -140,7 +151,7 @@ packageFromSource :: FilePath -> PackageConfig -> IO (Maybe PackageDescr, PackageCollectStats) packageFromSource cabalPath packageConfig = do setCurrentDirectory dirPath- ghcFlags <- figureOutGhcOpts+ ghcFlags <- figureOutGhcOpts' dirPath debugM "leksah-server" ("ghcFlags: " ++ show ghcFlags) NewException.catch (inner ghcFlags) handler where@@ -151,18 +162,20 @@ warningM "leksah-server" ("Ghc failed to process: " ++ show e ++ " (" ++ cabalPath ++ ")") return (Nothing, PackageCollectStats packageName Nothing False False (Just ("Ghc failed to process: " <> T.pack (show e) <> " (" <> T.pack cabalPath <> ")")))- inner ghcFlags = inGhcIO ghcFlags [Opt_Haddock] [] $ \ dflags -> do- (interfaces,_) <- processModules verbose (exportedMods ++ hiddenMods) [] []- liftIO $ print (length interfaces)- let mods = map (interfaceToModuleDescr dflags dirPath (packId $ getThisPackage packageConfig)) interfaces- sp <- liftIO $ myCanonicalizePath dirPath- let pd = PackageDescr {- pdPackage = packId (getThisPackage packageConfig)- , pdModules = mods- , pdBuildDepends = [] -- TODO depends packageConfig- , pdMbSourcePath = Just sp}- let stat = PackageCollectStats packageName (Just (length mods)) True False Nothing- liftIO $ deepseq pd $ return (Just pd, stat)+ inner ghcFlags = do+ libDir <- getSysLibDir VERSION_ghc+ inGhcIO libDir ghcFlags [Opt_Haddock] [] $ \ dflags -> do+ (interfaces,_) <- processModules verbose (exportedMods ++ hiddenMods) [] []+ liftIO $ print (length interfaces)+ let mods = map (interfaceToModuleDescr dflags dirPath (packId $ getThisPackage packageConfig)) interfaces+ sp <- liftIO $ myCanonicalizePath dirPath+ let pd = PackageDescr {+ pdPackage = packId (getThisPackage packageConfig)+ , pdModules = mods+ , pdBuildDepends = [] -- TODO depends packageConfig+ , pdMbSourcePath = Just sp}+ let stat = PackageCollectStats packageName (Just (length mods)) True False Nothing+ liftIO $ deepseq pd $ return (Just pd, stat) #if MIN_VERSION_ghc(7,10,0) exportedMods = map (moduleNameString . exposedName) $ exposedModules packageConfig hiddenMods = map moduleNameString $ hiddenModules packageConfig@@ -227,12 +240,14 @@ transformToDescrs :: DynFlags -> PackModule -> [(LHsDecl Name, Maybe NDoc, [(Name, Maybe NDoc)])] -> [Descr] transformToDescrs dflags pm = concatMap transformToDescr where-#if MIN_VERSION_ghc(7,10,0)+#if MIN_VERSION_ghc(8,0,0)+ transformToDescr (L loc (SigD (TypeSig names typ)), mbComment, _subCommentList) = map nameDescr names+#elif MIN_VERSION_ghc(7,10,0) transformToDescr (L loc (SigD (TypeSig names typ _)), mbComment, _subCommentList) = map nameDescr names #elif MIN_VERSION_ghc(7,2,0)- transformToDescr ((L loc (SigD (TypeSig names typ))), mbComment,_subCommentList) = map nameDescr names+ transformToDescr (L loc (SigD (TypeSig names typ)), mbComment,_subCommentList) = map nameDescr names #else- transformToDescr ((L loc (SigD (TypeSig name' typ))), mbComment,_subCommentList) = [nameDescr name']+ transformToDescr (L loc (SigD (TypeSig name' typ)), mbComment,_subCommentList) = [nameDescr name'] #endif where nameDescr name = Real RealDescr {@@ -244,6 +259,37 @@ , dscTypeHint' = VariableDescr , dscExported' = True} +#if MIN_VERSION_ghc(7,8,0)+#if MIN_VERSION_ghc(8,2,0)+ transformToDescr (L loc (SigD (PatSynSig names typ)), mbComment, _subCommentList) = (<$> names) $ \name ->+#elif MIN_VERSION_ghc(8,0,0)+ transformToDescr (L loc (SigD (PatSynSig name typ)), mbComment, _subCommentList) = pure $+#else+ transformToDescr (L loc (SigD (PatSynSig name _ _ _ typ)), mbComment, _subCommentList) = pure $+#endif+ Real RealDescr {+ dscName' = T.pack . getOccString $ unLoc name+ , dscMbTypeStr' = Just . BS.pack $ getOccString (unLoc name) <> " :: " <> showSDocUnqual dflags (ppr typ)+ , dscMbModu' = Just pm+ , dscMbLocation' = srcSpanToLocation loc+ , dscMbComment' = toComment dflags mbComment []+ , dscTypeHint' = PatternSynonymDescr+ , dscExported' = True}+#endif++#if MIN_VERSION_ghc(8,0,0)+ transformToDescr (L loc (SigD (ClassOpSig _ names typ)), mbComment, _subCommentList) =+ map (\name ->+ Real RealDescr {+ dscName' = T.pack . getOccString $ unLoc name+ , dscMbTypeStr' = Just . BS.pack $ getOccString (unLoc name) <> " :: " <> showSDocUnqual dflags (ppr typ)+ , dscMbModu' = Just pm+ , dscMbLocation' = srcSpanToLocation loc+ , dscMbComment' = toComment dflags mbComment []+ , dscTypeHint' = PatternSynonymDescr+ , dscExported' = True}) names+#endif+ transformToDescr (L _loc (SigD _), _mbComment, _subCommentList) = [] #if MIN_VERSION_ghc(7,6,0)@@ -308,8 +354,8 @@ constructors = concatMap (extractConstructor dflags) lConDecl fields = nub $ concatMap (extractRecordFields dflags) lConDecl name = getOccString (unLoc lid)- derivings Nothing = []- derivings (Just _l) = []+ derivings :: HsDeriving Name -> [Descr]+ derivings _l = [] -- concatMap (extractDeriving dflags pm name) (unLoc710 l) #if !MIN_VERSION_ghc(7,6,0) transformToDescr ((L loc (TyClD typ@(TyData NewType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_subCommentList) =@@ -370,40 +416,56 @@ in concatMap (extractMethod dflags) pairs extractMethod :: DynFlags -> (LHsDecl Name, Maybe NDoc) -> [SimpleDescr]-#if MIN_VERSION_ghc(7,10,0)-extractMethod dflags (L loc (SigD ts@(TypeSig names _typ _)), mbDoc) = map extractName names+#if MIN_VERSION_ghc(8,0,0)+extractMethod dflags (L loc (SigD ts@(TypeSig names _typ)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names+#if MIN_VERSION_ghc(8,2,0)+extractMethod dflags (L loc (SigD ts@(PatSynSig names _typ)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names+#else+extractMethod dflags (L loc (SigD ts@(PatSynSig name _typ)), mbDoc) = [extractMethodName dflags loc ts mbDoc name]+#endif+extractMethod dflags (L loc (SigD ts@(ClassOpSig _ names _typ)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names+#elif MIN_VERSION_ghc(7,10,0)+extractMethod dflags (L loc (SigD ts@(TypeSig names _typ _)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names #elif MIN_VERSION_ghc(7,2,0)-extractMethod dflags (L loc (SigD ts@(TypeSig names _typ)), mbDoc) = map extractName names+extractMethod dflags (L loc (SigD ts@(TypeSig names _typ)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names #else-extractMethod dflags (L loc (SigD ts@(TypeSig name' _typ)), mbDoc) = [extractName name']+extractMethod dflags (L loc (SigD ts@(TypeSig name' _typ)), mbDoc) = [extractMethodName dflags loc ts mbDoc name'] #endif- where- extractName name =+extractMethod _ _ = []++extractMethodName :: (NamedThing a, Outputable o) => DynFlags+ -> SrcSpan -> o -> Maybe NDoc -> GenLocated l a -> SimpleDescr+extractMethodName dflags loc ts mbDoc name = SimpleDescr (T.pack . getOccString $ unLoc name) (Just . BS.pack . showSDocUnqual dflags $ ppr ts) (srcSpanToLocation loc) (toComment dflags mbDoc []) True-extractMethod _dflags (_, _mbDoc) = [] extractConstructor :: DynFlags -> LConDecl Name -> [SimpleDescr]-#if MIN_VERSION_ghc(7,10,0)+#if MIN_VERSION_ghc(8,0,0)+extractConstructor dflags decl@(L loc d) = extractDecl d+ where+ extractDecl (ConDeclGADT {..}) = map (extractName con_doc) con_names+ extractDecl (ConDeclH98 {..}) = [extractName con_doc con_name]+#elif MIN_VERSION_ghc(7,10,0) extractConstructor dflags decl@(L loc (ConDecl {con_names = names, con_doc = doc})) =- map extractName names+ map (extractName doc) names+ where #else extractConstructor dflags decl@(L loc (ConDecl {con_name = name', con_doc = doc})) =- [extractName name']-#endif+ [extractName doc name'] where- extractName name =+#endif+ extractName doc name = SimpleDescr (T.pack . getOccString $ unLoc name) (Just . BS.pack . showSDocUnqual dflags . ppr $uncommentDecl decl) (srcSpanToLocation loc) (case doc of Nothing -> Nothing- Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d)+ Just (L _ d') -> Just . BS.pack . T.unpack $ printHsDoc d') True #if MIN_VERSION_ghc(7,10,0)@@ -415,7 +477,11 @@ #endif extractRecordFields :: DynFlags -> LConDecl Name -> [SimpleDescr]+#if MIN_VERSION_ghc(8,0,0)+extractRecordFields dflags (L _ _decl@ConDeclH98 {con_details = RecCon flds}) =+#else extractRecordFields dflags (L _ _decl@(ConDecl {con_details=(RecCon flds)})) =+#endif concatMap extractRecordFields' (unLoc710 flds) where #if MIN_VERSION_ghc(7,10,0)@@ -428,13 +494,28 @@ where extractName name = SimpleDescr- (T.pack . getOccString $ unLoc name)+ (T.pack . showSDoc dflags . ppr $ unLoc710 name) (Just (BS.pack (showSDocUnqual dflags $ ppr typ))) (srcSpanToLocation $ getLoc name) (case doc of Nothing -> Nothing Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d) True+#if MIN_VERSION_ghc(8,0,0)+extractRecordFields dflags (L _ _decl@ConDeclGADT+ {con_names = names, con_type = typ, con_doc = doc}) =+ map extractName names+ where+ extractName name =+ SimpleDescr+ (T.pack . showSDoc dflags . ppr $ unLoc710 name)+ (Just (BS.pack (showSDocUnqual dflags $ ppr typ)))+ (srcSpanToLocation $ getLoc name)+ (case doc of+ Nothing -> Nothing+ Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d)+ True+#endif extractRecordFields _ _ = [] toComment :: DynFlags -> Maybe NDoc -> [NDoc] -> Maybe ByteString
src/IDE/Metainfo/SourceDB.hs view
@@ -185,16 +185,16 @@ packageDescriptionParser = try (do whiteSpace str <- many (noneOf ":")- char ':'+ _ <- char ':' return (packageIdentifierFromString (T.pack str))) <?> "packageDescriptionParser" filePathParser :: CharParser () FilePath filePathParser = try (do whiteSpace- char '"'+ _ <- char '"' str <- many (noneOf "\"")- char '"'+ _ <- char '"' return str) <?> "filePathParser" @@ -227,22 +227,22 @@ cabalMinimalP :: CharParser () (Either Text Text) cabalMinimalP =- do try $(symbol "name:" <|> symbol "Name:")+ do _ <- try $ symbol "name:" <|> symbol "Name:" whiteSpace name <- many $noneOf " \n"- many $noneOf "\n"- char '\n'+ _ <- many $noneOf "\n"+ _ <- char '\n' return . Right $ T.pack name <|> do- try $(symbol "version:" <|> symbol "Version:")+ _ <- try $ symbol "version:" <|> symbol "Version:" whiteSpace versionString <- many $noneOf " \n"- many $noneOf "\n"- char '\n'+ _ <- many $noneOf "\n"+ _ <- char '\n' return . Left $ T.pack versionString <|> do- many $noneOf "\n"- char '\n'+ _ <- many $noneOf "\n"+ _ <- char '\n' cabalMinimalP <?> "cabal minimal"
src/IDE/Metainfo/WorkspaceCollector.hs view
@@ -1,4 +1,8 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables, PatternGuards, OverloadedStrings #-} ----------------------------------------------------------------------------- --@@ -31,6 +35,7 @@ import Control.Applicative hiding(empty)+import Control.Arrow ((&&&)) import Prelude import IDE.Utils.Utils import IDE.Utils.GHCUtils@@ -76,7 +81,7 @@ import qualified Maybes as M import IDE.Metainfo.InterfaceCollector import Data.Maybe- (isJust, catMaybes, isNothing)+ (isJust, catMaybes, isNothing, mapMaybe) import PrelNames import System.Log.Logger import Control.DeepSeq (deepseq)@@ -87,7 +92,22 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Monoid ((<>))+#if MIN_VERSION_ghc(8,2,0)+import DynFlags (thisPackage)+import Module (toInstalledUnitId, InstalledModule(..), UnitId(..), DefUnitId(..))+import HsImpExp (ieWrappedName)+#endif +#if !MIN_VERSION_ghc(8,2,0)+mkPackageName :: String -> PackageName+mkPackageName = PackageName+ieWrappedName :: RdrName -> RdrName+ieWrappedName = id+type OutputableBndrId = OutputableBndr+toInstalledUnitId :: GHC.UnitId -> GHC.UnitId+toInstalledUnitId = id+#endif+ type NDecl = LHsDecl RdrName myDocEmpty :: NDoc myDocAppend :: NDoc -> NDoc -> NDoc@@ -112,11 +132,10 @@ showRdrName :: DynFlags -> RdrName -> Text showRdrName dflags r = T.pack . showSDoc dflags $ ppr r --- | Test collectWorkspace :: PackageIdentifier -> [(Text,FilePath)] -> Bool -> Bool -> FilePath -> IO() collectWorkspace pid moduleList forceRebuild writeAscii dir = do debugM "leksah-server" $ "collectWorkspace called with modules " ++ show moduleList ++ " in folder " ++ dir- collectorPath <- liftIO $ getCollectorPath+ collectorPath <- liftIO getCollectorPath let packageCollectorPath = collectorPath </> T.unpack (packageIdentifierToString pid) when forceRebuild $ do exists <- doesDirectoryExist packageCollectorPath@@ -124,44 +143,44 @@ -- Construct directory liftIO $ createDirectoryIfMissing True packageCollectorPath setCurrentDirectory dir- opts1 <- filterOpts <$> figureOutGhcOpts+ opts1 <- filterOpts <$> figureOutGhcOpts dir opts2 <- figureOutHaddockOpts - debugM "leksah-server" $ ("before collect modules" ++ "\n\nopts1: " ++ show opts1 ++ "\n\n opt2: " ++ show opts2)- mapM_ (collectModule packageCollectorPath writeAscii pid opts1) moduleList- debugM "leksah-server" $ "after collect modules"+ libDir <- getSysLibDir VERSION_ghc+ debugM "leksah-server" $ "before collect modules" ++ "\n\nopts1: " ++ show opts1 ++ "\n\n opt2: " ++ show opts2+ mapM_ (collectModule libDir packageCollectorPath writeAscii pid opts1) moduleList+ debugM "leksah-server" "after collect modules" where filterOpts :: [Text] -> [Text] filterOpts [] = [] filterOpts (o:_:r) | o `elem` ["-link-js-lib", "-js-lib-outputdir", "-js-lib-src", "-package-id"] = filterOpts r filterOpts (o:r) = o:filterOpts r -collectModule :: FilePath -> Bool -> PackageIdentifier -> [Text] -> (Text,FilePath) -> IO()-collectModule collectorPackagePath writeAscii pid opts (modId,sourcePath) = do+collectModule :: FilePath -> FilePath -> Bool -> PackageIdentifier -> [Text] -> (Text,FilePath) -> IO()+collectModule libDir collectorPackagePath writeAscii pid opts (modId,sourcePath) = case parseModuleKey (T.unpack modId) sourcePath of Nothing -> errorM "leksah-server" (T.unpack $ "Can't parse module name " <> modId) Just modKey -> do- let collectorModulePath = collectorPackagePath </> (moduleCollectorFileName modKey) <.> leksahMetadataWorkspaceFileExtension+ let collectorModulePath = collectorPackagePath </> moduleCollectorFileName modKey <.> leksahMetadataWorkspaceFileExtension moduleName' = moduleKeyToName modKey existCollectorFile <- doesFileExist collectorModulePath existSourceFile <- doesFileExist sourcePath if existSourceFile- then do+ then if not existCollectorFile- then collectModule' sourcePath collectorModulePath writeAscii pid opts moduleName'+ then collectModule' libDir sourcePath collectorModulePath writeAscii pid opts moduleName' else do sourceModTime <- getModificationTime sourcePath collModTime <- getModificationTime collectorModulePath- if sourceModTime > collModTime- then collectModule' sourcePath collectorModulePath writeAscii pid+ when (sourceModTime > collModTime) $+ collectModule' libDir sourcePath collectorModulePath writeAscii pid opts moduleName'- else return () else errorM "leksah-server" ("source file not found " ++ sourcePath) -collectModule' :: FilePath -> FilePath -> Bool -> PackageIdentifier -> [Text] -> ModuleName -> IO()-collectModule' sourcePath destPath writeAscii pid opts moduleName' = gcatch (- inGhcIO (opts++["-cpp"]) [Opt_Haddock] [] $ \ dynFlags -> do+collectModule' :: FilePath -> FilePath -> FilePath -> Bool -> PackageIdentifier -> [Text] -> ModuleName -> IO()+collectModule' libDir sourcePath destPath writeAscii pid opts moduleName' = gcatch (+ inGhcIO libDir (opts++["-cpp"]) [Opt_Haddock] [] $ \ dynFlags -> do session <- getSession #if MIN_VERSION_ghc(7,2,0) (dynFlags3,fp') <- liftIO $ preprocess session (sourcePath,Nothing)@@ -170,14 +189,14 @@ #endif let packIdAndKey = PackageIdAndKey pid #if MIN_VERSION_ghc(7,10,0)- (thisPackage dynFlags3)+ (toInstalledUnitId $ thisPackage dynFlags3) #endif mbInterfaceDescr <- mayGetInterfaceDescription dynFlags packIdAndKey moduleName' liftIO $ do stringBuffer <- hGetStringBuffer fp' parseResult <- myParseModule dynFlags3 sourcePath (Just stringBuffer) case parseResult of- Right (L _ hsMod@(HsModule{})) -> do+ Right (L _ hsMod@HsModule{}) -> do let moduleDescr = extractModDescr dynFlags pid moduleName' sourcePath hsMod let moduleDescr' = case mbInterfaceDescr of Nothing -> moduleDescr@@ -190,7 +209,7 @@ mdModuleId = PM pid moduleName' , mdMbSourcePath = Just sourcePath , mdReferences = Map.empty -- imports- , mdIdDescriptions = [Real $ RealDescr {+ , mdIdDescriptions = [Real RealDescr { dscName' = "Parse Error" , dscMbTypeStr' = Nothing , dscMbModu' = Just (PM pid moduleName')@@ -233,7 +252,7 @@ , mdIdDescriptions = descrs'} where descrs = extractDescrs dflags (PM pid moduleName') (hsmodDecls hsMod)- descrs' = fixExports dflags (fmap unLoc710 $ hsmodExports hsMod) descrs+ descrs' = fixExports dflags (unLoc710 <$> hsmodExports hsMod) descrs modFile (Just (L loc _)) = (locationFile <$> srcSpanToLocation loc) <|> Just sourcePath modFile _ = Just sourcePath@@ -250,24 +269,33 @@ fixDescr list (Real rd) = Real rd' where rd' = case dscTypeHint' rd of- VariableDescr -> rd{dscExported' = isJust findVar}- InstanceDescr _ -> rd- _ -> case findThing of- Nothing -> nothingExported rd- Just (IEThingAll _) -> allExported rd- Just (IEThingAbs _) -> someExported rd []- Just (IEThingWith _ l) -> someExported rd (map (showRdrName dflags . unLoc710) l)- _ -> allExported rd+ VariableDescr -> rd{dscExported' = isJust findVar}+ PatternSynonymDescr -> rd{dscExported' = isJust findVar}+ InstanceDescr _ -> rd+ _ -> case findThing of+ Nothing -> nothingExported rd+ Just (IEThingAll _) -> allExported rd+ Just (IEThingAbs _) -> someExported rd []+#if MIN_VERSION_ghc(8,0,0)+ Just (IEThingWith _ _ l _) -> someExported rd (map (showRdrName dflags . ieWrappedName . unLoc710) l)+#else+ Just (IEThingWith _ l) -> someExported rd (map (showRdrName dflags . unLoc710) l)+#endif+ _ -> allExported rd findVar = find (\ a -> case a of- IEVar r | showRdrName dflags (unLoc710 r) == dscName' rd -> True+ IEVar r | showRdrName dflags (ieWrappedName $ unLoc710 r) == dscName' rd -> True _ -> False) list findThing = find (\ a -> case a of- IEThingAbs r | showRdrName dflags (unLoc710 r) == dscName' rd -> True- IEThingAll r | showRdrName dflags (unLoc710 r) == dscName' rd -> True+ IEThingAbs r | showRdrName dflags (ieWrappedName $ unLoc710 r) == dscName' rd -> True+ IEThingAll r | showRdrName dflags (ieWrappedName $ unLoc710 r) == dscName' rd -> True+#if MIN_VERSION_ghc(8,0,0)+ IEThingWith r _ _list _ | showRdrName dflags (ieWrappedName $ unLoc710 r) == dscName' rd -> True+#else IEThingWith r _list | showRdrName dflags (unLoc710 r) == dscName' rd -> True+#endif _ -> False) list allExported rd = rd@@ -295,7 +323,7 @@ setExportedSD bool sd = sd{sdExported = bool}- maySetExportedSD list sd = sd{sdExported = elem (sdName sd) list}+ maySetExportedSD list sd = sd{sdExported = sdName sd `elem` list} extractDescrs :: DynFlags -> PackModule -> [NDecl] -> [Descr]@@ -314,17 +342,17 @@ filterUninteresting :: [(NDecl,Maybe NDoc)] -> [(NDecl,Maybe NDoc)] filterUninteresting = filter filterSignature where- filterSignature ((L _srcDecl (SpliceD _)),_) = False- filterSignature ((L _srcDecl (RuleD _)),_) = False- filterSignature ((L _srcDecl (WarningD _)),_) = False- filterSignature ((L _srcDecl (ForD _)),_) = False- filterSignature ((L _srcDecl (DefD _)),_) = False- filterSignature _ = True+ filterSignature (L _srcDecl (SpliceD _),_) = False+ filterSignature (L _srcDecl (RuleD _),_) = False+ filterSignature (L _srcDecl (WarningD _),_) = False+ filterSignature (L _srcDecl (ForD _),_) = False+ filterSignature (L _srcDecl (DefD _),_) = False+ filterSignature _ = True partitionSignatures :: [(NDecl,Maybe NDoc)] -> ([(NDecl,Maybe NDoc)],[(NDecl,Maybe NDoc)]) partitionSignatures = partition filterSignature where- filterSignature ((L _srcDecl (SigD _)),_) = False+ filterSignature (L _srcDecl (SigD _),_) = False filterSignature _ = True --partitionInstances :: [(NDecl,Maybe NDoc)] -> ([(NDecl,Maybe NDoc)],[(NDecl,Maybe NDoc)])@@ -335,10 +363,10 @@ -- filterInstances _ = True -- | Collect the docs and attach them to the right declaration.-collectDocs :: [LHsDecl RdrName] -> [(LHsDecl RdrName, (Maybe NDoc))]+collectDocs :: [LHsDecl RdrName] -> [(LHsDecl RdrName, Maybe NDoc)] collectDocs = collect Nothing myDocEmpty -collect :: Maybe (LHsDecl RdrName) -> NDoc -> [LHsDecl RdrName] -> [(LHsDecl RdrName, (Maybe (NDoc)))]+collect :: Maybe (LHsDecl RdrName) -> NDoc -> [LHsDecl RdrName] -> [(LHsDecl RdrName, Maybe NDoc)] collect d doc_so_far [] = case d of Nothing -> []@@ -357,7 +385,7 @@ Nothing -> collect (Just e) doc_so_far es Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) myDocEmpty es) -finishedDoc :: LHsDecl RdrName -> NDoc -> [(LHsDecl RdrName, (Maybe NDoc))] -> [(LHsDecl RdrName, (Maybe NDoc))]+finishedDoc :: LHsDecl RdrName -> NDoc -> [(LHsDecl RdrName, Maybe NDoc)] -> [(LHsDecl RdrName, Maybe NDoc)] finishedDoc d doc rest | isEmptyDoc doc = (d, Nothing) : rest finishedDoc d doc rest | notDocDecl d = (d, Just doc) : rest where@@ -367,7 +395,9 @@ sigNameNoLoc' :: Sig name -> [name] #if MIN_VERSION_ghc(7,2,0)-#if MIN_VERSION_ghc(7,10,0)+#if MIN_VERSION_ghc(8,0,0)+sigNameNoLoc' (TypeSig ns _) = map unLoc ns+#elif MIN_VERSION_ghc(7,10,0) sigNameNoLoc' (TypeSig ns _ _) = map unLoc ns #else sigNameNoLoc' (TypeSig ns _) = map unLoc ns@@ -381,49 +411,70 @@ #endif sigNameNoLoc' _ = [] #else-sigNameNoLoc' = maybe [] (:[]) . sigNameNoLoc+sigNameNoLoc' = maybeToList sigNameNoLoc #endif -attachSignatures :: DynFlags -> [(NDecl, (Maybe NDoc))] -> [(NDecl,Maybe NDoc)]- -> [(NDecl, (Maybe NDoc), [(NSig,Maybe NDoc)])]+attachSignatures :: DynFlags -> [(NDecl, Maybe NDoc)] -> [(NDecl,Maybe NDoc)]+ -> [(NDecl, Maybe NDoc, [(NSig,Maybe NDoc)])] attachSignatures dflags signatures = map (attachSignature signaturesMap) where signaturesMap = Map.fromListWith (++) $ concatMap sigMap signatures + sigMap :: (NDecl, Maybe NDoc) -> [(RdrName, [(NSig,Maybe NDoc)])] sigMap (L loc (SigD sig),c) | nameList <- sigNameNoLoc' sig = map (\n -> (n, [(L loc sig,c)])) nameList 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)])+ attachSignature :: Map RdrName [(NSig,Maybe NDoc)] -> (NDecl, Maybe NDoc)+ -> (NDecl, Maybe NDoc, [(NSig,Maybe NDoc)]) attachSignature signaturesMap' (decl,mbDoc) = case declName (unLoc decl) of Nothing -> (decl,mbDoc, []) Just name -> case name `Map.lookup` signaturesMap' of Just sigList -> (decl,mbDoc, sigList) Nothing -> (decl, mbDoc, [])- declName _t@(TyClD x) = Just (tcdName x)- declName _t@(ValD (FunBind fun_id' _ _ _ _ _ )) = Just (unLoc fun_id')- declName _ = Nothing+ declName _t@(TyClD x) = Just (tcdName x)+ declName _t@(ValD FunBind {fun_id = fun_id'}) = Just (unLoc fun_id')+ declName _ = Nothing -transformToDescrs :: DynFlags -> PackModule -> [(NDecl, (Maybe NDoc), [(NSig, Maybe NDoc)])] -> [Descr]+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 {+ transformToDescr :: (NDecl, Maybe NDoc, [(NSig, Maybe NDoc)]) -> [Descr]+ transformToDescr (L loc (ValD FunBind {fun_id = lid}), mbComment, sigList) =+ [Real RealDescr { dscName' = showRdrName dflags (unLoc lid) , dscMbTypeStr' = sigToByteString dflags sigList , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc- , dscMbComment' = toComment mbComment (catMaybes (map snd sigList))+ , dscMbComment' = toComment mbComment (mapMaybe snd sigList) , dscTypeHint' = VariableDescr , dscExported' = True}] +#if MIN_VERSION_ghc(7,8,0)+#if MIN_VERSION_ghc(7,10,0)+ transformToDescr (L loc (ValD (PatSynBind PSB{..})), mbComment,sigList) =+#else+ transformToDescr (L loc (ValD PatSynBind{..}), mbComment,sigList) =+#endif+ [Real RealDescr {+#if MIN_VERSION_ghc(7,10,0)+ dscName' = showRdrName dflags (unLoc psb_id)+#else+ dscName' = showRdrName dflags (unLoc patsyn_id)+#endif+ , dscMbTypeStr' = sigToByteString dflags sigList+ , dscMbModu' = Just pm+ , dscMbLocation' = srcSpanToLocation loc+ , dscMbComment' = toComment mbComment (catMaybes (map snd sigList))+ , dscTypeHint' = PatternSynonymDescr+ , dscExported' = True}]+#endif+ #if MIN_VERSION_ghc(7,7,0)- transformToDescr ((L loc for@(ForD (ForeignImport lid _ _ _))), mbComment,_sigList) =- [Real $ RealDescr {+ transformToDescr (L loc for@(ForD (ForeignImport lid _ _ _)), mbComment,_sigList) =+ [Real RealDescr { dscName' = showRdrName dflags (unLoc lid) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr for)) , dscMbModu' = Just pm@@ -432,8 +483,8 @@ , dscTypeHint' = TypeDescr , dscExported' = True}] - transformToDescr ((L loc (TyClD typ@(FamDecl {tcdFam = (FamilyDecl{ fdLName = lid})}))), mbComment,_sigList) =- [Real $ RealDescr {+ 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@@ -442,8 +493,8 @@ , dscTypeHint' = TypeDescr , dscExported' = True}] - transformToDescr ((L loc (TyClD typ@(SynDecl {tcdLName = lid}))), mbComment,_sigList) =- [Real $ RealDescr {+ 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@@ -452,25 +503,30 @@ , dscTypeHint' = TypeDescr , dscExported' = True}] - transformToDescr ((L loc (TyClD typ@(DataDecl {tcdLName = lid, tcdDataDefn = HsDataDefn {dd_cons=lConDecl, dd_derivs=tcdDerivs'}}))), mbComment,_sigList) =- [Real $ RealDescr {+ 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'+ , dscExported' = True}+ : derivings tcdDerivs' where constructors = concatMap (extractConstructor dflags) lConDecl fields = nub $ concatMap (extractRecordFields dflags) lConDecl name = showRdrName dflags (unLoc lid)+#if MIN_VERSION_ghc(8,2,0)+ derivings :: HsDeriving RdrName -> [Descr]+ derivings l = concatMap (extractDeriving dflags pm name) (unLoc710 l)+#else derivings Nothing = [] derivings (Just l) = map (extractDeriving dflags pm name) (unLoc710 l)+#endif #elif MIN_VERSION_ghc(7,6,0)- transformToDescr ((L loc (TyClD typ@(ForeignType {tcdLName = lid}))), mbComment,_sigList) =- [Real $ RealDescr {+ 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@@ -479,8 +535,8 @@ , dscTypeHint' = TypeDescr , dscExported' = True}] - transformToDescr ((L loc (TyClD typ@(TyFamily {tcdLName = lid}))), mbComment,_sigList) =- [Real $ RealDescr {+ 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@@ -489,8 +545,8 @@ , dscTypeHint' = TypeDescr , dscExported' = True}] - transformToDescr ((L loc (TyClD typ@(TyDecl {tcdLName = lid, tcdTyDefn = TySynonym {}}))), mbComment,_sigList) =- [Real $ RealDescr {+ 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@@ -499,16 +555,16 @@ , dscTypeHint' = TypeDescr , dscExported' = True}] - transformToDescr ((L loc (TyClD typ@(TyDecl {tcdLName = lid, tcdTyDefn = TyData {td_cons=lConDecl, td_derivs=tcdDerivs'}}))), mbComment,_sigList) =- [Real $ RealDescr {+ 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'+ , dscExported' = True}+ : derivings tcdDerivs' where constructors = concatMap (extractConstructor dflags) lConDecl fields = nub $ concatMap (extractRecordFields dflags) lConDecl@@ -516,8 +572,8 @@ derivings Nothing = [] derivings (Just l) = map (extractDeriving dflags pm name) l #else- transformToDescr ((L loc (TyClD typ@(TySynonym lid _ _ _ ))), mbComment,_sigList) =- [Real $ RealDescr {+ transformToDescr (L loc (TyClD typ@(TySynonym lid _ _ _ )), mbComment,_sigList) =+ [Real RealDescr { dscName' = showRdrName dflags (unLoc lid) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) , dscMbModu' = Just pm@@ -526,16 +582,16 @@ , dscTypeHint' = TypeDescr , dscExported' = True}] - transformToDescr ((L loc (TyClD typ@(TyData DataType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_sigList) =- [Real $ RealDescr {+ transformToDescr (L loc (TyClD typ@(TyData DataType _ tcdLName' _ _ _ lConDecl 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'+ , dscExported' = True}+ : derivings tcdDerivs' where constructors = map (extractConstructor dflags) lConDecl fields = nub $ concatMap (extractRecordFields dflags) lConDecl@@ -543,16 +599,16 @@ derivings Nothing = [] derivings (Just l) = map (extractDeriving dflags pm name) l - transformToDescr ((L loc (TyClD typ@(TyData NewType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_sigList) =- [Real $ RealDescr {+ transformToDescr (L loc (TyClD typ@(TyData NewType _ tcdLName' _ _ _ lConDecl 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' = NewtypeDescr constructor mbField- , dscExported' = True}]- ++ derivings tcdDerivs'+ , dscExported' = True}+ : derivings tcdDerivs' where constructor = forceHead (map (extractConstructor dflags) lConDecl) "WorkspaceCollector>>transformToDescr: no constructor for newtype"@@ -564,8 +620,8 @@ 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 {+ transformToDescr (L loc (TyClD cl@ClassDecl{tcdLName=tcdLName', tcdSigs=tcdSigs', tcdDocs=docs}), mbComment,_sigList) =+ [Real RealDescr { dscName' = showRdrName dflags (unLoc tcdLName') , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr cl{tcdMeths = emptyLHsBinds})) , dscMbModu' = Just pm@@ -578,7 +634,7 @@ super = [] #if MIN_VERSION_ghc(7,7,0)- transformToDescr ((L loc (InstD inst)), mbComment, _sigList) =+ transformToDescr (L loc (InstD inst), mbComment, _sigList) = let typp = case inst of ClsInstD t -> ppr t DataFamInstD t -> ppr t@@ -598,10 +654,10 @@ where #elif MIN_VERSION_ghc(7,6,0)- transformToDescr ((L loc (InstD _inst@(ClsInstD typ _ _ _))), mbComment, _sigList) =- [Real $ RealDescr {+ transformToDescr (L loc (InstD _inst@(ClsInstD typ _ _ _)), mbComment, _sigList) =+ [Real RealDescr { dscName' = name- , dscMbTypeStr' = Just (BS.pack ("instance " ++ (showSDocUnqual dflags $ppr typ)))+ , dscMbTypeStr' = Just (BS.pack ("instance " ++ showSDocUnqual dflags (ppr typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment []@@ -612,10 +668,10 @@ [] -> ("",[]) hd:tl -> (hd,tl) #else- transformToDescr ((L loc (InstD _inst@(InstDecl typ _ _ _))), mbComment, _sigList) =- [Real $ RealDescr {+ transformToDescr (L loc (InstD _inst@(InstDecl typ _ _ _)), mbComment, _sigList) =+ [Real RealDescr { dscName' = name- , dscMbTypeStr' = Just (BS.pack ("instance " ++ (showSDocUnqual dflags $ppr typ)))+ , dscMbTypeStr' = Just (BS.pack ("instance " ++ showSDocUnqual dflags (ppr typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment []@@ -638,13 +694,20 @@ 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}+uncommentData td@TyData {tcdCons = conDecls} = td{tcdCons = map uncommentDecl conDecls} #endif uncommentData other = other uncommentDecl :: LConDecl a -> LConDecl a+#if MIN_VERSION_ghc(8,0,1)+uncommentDecl (L l cd@ConDeclGADT{}) =+ L l cd{con_doc = Nothing}+uncommentDecl (L l cd@ConDeclH98{}) =+ L l cd{con_details= uncommentDetails (con_details cd), con_doc = Nothing}+#else uncommentDecl (L l cd) = L l cd{con_details= uncommentDetails (con_details cd)}+#endif uncommentDetails :: HsConDeclDetails a -> HsConDeclDetails a #if MIN_VERSION_ghc(7,10,0)@@ -667,7 +730,7 @@ mergeIdDescrs d1 d2 = dres ++ reexported where (reexported,real) = partition isReexported d2- lm = Map.fromList $ zip (map (\d -> (dscName d,dscTypeHint d)) real) real+ lm = Map.fromList $ zip (map (dscName &&& dscTypeHint) real) real dres = map (addType lm) d1 addType lm' (Real d1') | isNothing (dscMbTypeStr' d1') =@@ -676,9 +739,20 @@ Just d -> dscMbTypeStr d} addType _ d = d +#if MIN_VERSION_ghc(8,2,0)+extractDeriving :: OutputableBndrId alpha => DynFlags -> PackModule -> Text -> LHsDerivingClause alpha -> [Descr]+extractDeriving dflags pm name (L _ HsDerivingClause {deriv_clause_tys = L _ c}) = map (extractDeriving' dflags pm name) c++extractDeriving' :: OutputableBndrId alpha => DynFlags -> PackModule -> Text -> LHsSigType alpha -> Descr+extractDeriving' dflags pm name (HsIB { hsib_body = (L loc typ) }) =+#elif MIN_VERSION_ghc(8,0,0)+extractDeriving :: OutputableBndr alpha => DynFlags -> PackModule -> Text -> LHsSigType alpha -> Descr+extractDeriving dflags pm name HsIB { hsib_body = (L loc typ) } =+#else extractDeriving :: OutputableBndr alpha => DynFlags -> PackModule -> Text -> LHsType alpha -> Descr extractDeriving dflags pm name (L loc typ) =- Real $ RealDescr {+#endif+ Real RealDescr { dscName' = className , dscMbTypeStr' = Just (BS.pack . T.unpack $ "instance " <> className <> " " <> name) , dscMbModu' = Just pm@@ -687,41 +761,57 @@ , dscTypeHint' = InstanceDescr (T.words name) , dscExported' = True} where- className = T.pack . showSDocUnqual dflags $ ppr typ+ className = T.pack . showSDocUnqual dflags $ ppr typ extractMethods :: DynFlags -> [LSig RdrName] -> [MyLDocDecl] -> [SimpleDescr] extractMethods dflags sigs docs = let pairs = attachComments sigs docs in concatMap (extractMethod dflags) pairs -extractMethod :: OutputableBndr alpha => DynFlags -> (LHsDecl alpha, Maybe (NDoc)) -> [SimpleDescr]-#if MIN_VERSION_ghc(7,10,0)-extractMethod dflags ((L loc (SigD ts@(TypeSig names _typ _))), mbDoc) = map extractName names+extractMethod :: OutputableBndrId alpha => DynFlags -> (LHsDecl alpha, Maybe NDoc) -> [SimpleDescr]+#if MIN_VERSION_ghc(8,0,0)+extractMethod dflags (L loc (SigD ts@(TypeSig names _typ)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names+#if MIN_VERSION_ghc(8,2,0)+extractMethod dflags (L loc (SigD ts@(PatSynSig names _typ)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names+#else+extractMethod dflags (L loc (SigD ts@(PatSynSig name _typ)), mbDoc) = [extractMethodName dflags loc ts mbDoc name]+#endif+extractMethod dflags (L loc (SigD ts@(ClassOpSig _ names _typ)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names+#elif MIN_VERSION_ghc(7,10,0)+extractMethod dflags (L loc (SigD ts@(TypeSig names _typ _)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names #elif MIN_VERSION_ghc(7,2,0)-extractMethod dflags ((L loc (SigD ts@(TypeSig names _typ))), mbDoc) = map extractName names+extractMethod dflags (L loc (SigD ts@(TypeSig names _typ)), mbDoc) = map (extractMethodName dflags loc ts mbDoc) names #else-extractMethod dflags ((L loc (SigD ts@(TypeSig name' _typ))), mbDoc) = [extractName name']+extractMethod dflags (L loc (SigD ts@(TypeSig name' _typ)), mbDoc) = [extractMethodName dflags loc ts mbDoc name'] #endif- where- extractName name =+extractMethod _ _ = []++extractMethodName :: (Outputable o1, Outputable o2) => DynFlags+ -> SrcSpan -> o1 -> Maybe NDoc -> GenLocated l o2 -> SimpleDescr+extractMethodName dflags loc ts mbDoc name = SimpleDescr (T.pack . showSDoc dflags . ppr $ unLoc name) (Just . BS.pack . showSDocUnqual dflags $ ppr ts) (srcSpanToLocation loc) (toComment mbDoc []) True-extractMethod _ (_, _mbDoc) = [] extractConstructor :: DynFlags -> Located (ConDecl RdrName) -> [SimpleDescr]-#if MIN_VERSION_ghc(7,10,0)+#if MIN_VERSION_ghc(8,0,0)+extractConstructor dflags decl@(L loc d') = extractDecl d'+ where+ extractDecl (ConDeclGADT {..}) = map (extractName con_doc) con_names+ extractDecl (ConDeclH98 {..}) = [extractName con_doc con_name]+#elif MIN_VERSION_ghc(7,10,0) extractConstructor dflags decl@(L loc (ConDecl {con_names = names, con_doc = doc})) =- map extractName names+ map (extractName doc) names+ where #else-extractConstructor dflags decl@(L loc (ConDecl {con_name = name', con_doc = doc})) =- [extractName name']-#endif+extractConstructor dflags decl@(L loc ConDecl {con_name = name', con_doc = doc}) =+ [extractName doc name'] where- extractName name =+#endif+ extractName doc name = SimpleDescr (T.pack . showSDoc dflags . ppr $ unLoc name) (Just . BS.pack . showSDocUnqual dflags . ppr $ uncommentDecl decl)@@ -732,15 +822,21 @@ True extractRecordFields :: DynFlags -> Located (ConDecl RdrName) -> [SimpleDescr]-extractRecordFields dflags (L _ _decl@(ConDecl {con_details = RecCon flds})) =+#if MIN_VERSION_ghc(8,0,0)+extractRecordFields dflags (L _ _decl@ConDeclH98 {con_details = RecCon flds}) =+#else+extractRecordFields dflags (L _ _decl@ConDecl {con_details = RecCon flds}) =+#endif concatMap extractRecordFields' (unLoc710 flds) where #if MIN_VERSION_ghc(7,10,0)+ extractRecordFields' :: OutputableBndrId name => LConDeclField name -> [SimpleDescr] extractRecordFields' (L _ _field@(ConDeclField names typ doc)) = map extractName names #else extractRecordFields' _field@(ConDeclField name' typ doc) = [extractName name'] #endif where+ extractName :: LFieldOcc name -> SimpleDescr extractName name = SimpleDescr (T.pack . showSDoc dflags . ppr $ unLoc710 name)@@ -750,11 +846,26 @@ Nothing -> Nothing Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d) True+#if MIN_VERSION_ghc(8,0,0)+extractRecordFields dflags (L _ _decl@ConDeclGADT+ {con_names = names, con_type = typ, con_doc = doc}) =+ map extractName names+ where+ extractName name =+ SimpleDescr+ (T.pack . showSDoc dflags . ppr $ unLoc710 name)+ (Just (BS.pack (showSDocUnqual dflags $ ppr typ)))+ (srcSpanToLocation $ getLoc name)+ (case doc of+ Nothing -> Nothing+ Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d)+ True+#endif 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))+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 :: DynFlags -> [(NSig, Maybe NDoc)] -> Maybe ByteString sigToByteString _ [] = Nothing@@ -775,7 +886,7 @@ (srcSpanEndLine span') (srcSpanEndCol span')) #endif -toComment :: Maybe (NDoc) -> [NDoc] -> Maybe ByteString+toComment :: Maybe NDoc -> [NDoc] -> Maybe ByteString toComment (Just c) _ = Just . BS.pack . T.unpack $ printHsDoc c toComment Nothing (c:_) = Just . BS.pack . T.unpack $ printHsDoc c toComment Nothing [] = Nothing@@ -797,18 +908,28 @@ mayGetInterfaceFile :: PackageIdAndKey -> ModuleName -> Ghc (Maybe (ModIface,FilePath)) mayGetInterfaceFile p mn = let pid = packId p- makeMod = mkModule-#if MIN_VERSION_ghc(7,10,0)- (packKey p)+#if MIN_VERSION_ghc(8,2,0)+ makeMod = mkModule (DefiniteUnitId (DefUnitId (packUnitId p)))+ makeInstMod = InstalledModule (packUnitId p)+#elif MIN_VERSION_ghc(8,0,0)+ makeMod = mkModule (packUnitId p)+#elif MIN_VERSION_ghc(7,10,0)+ makeMod = mkModule (packKey p) #else- (mkPackageId pid)+ makeMod = mkModule (mkPackageId pid) #endif- isBase = pkgName pid == (PackageName "base")- mn' = mkModuleName (display mn)- iface = findAndReadIface empty (if isBase- then mkBaseModule_ mn'- else makeMod mn') False- gblEnv = IfGblEnv { if_rec_types = Nothing }+ isBase = pkgName pid == mkPackageName "base"+ mn' = mkModuleName (display mn)+ iface = findAndReadIface+ empty+#if MIN_VERSION_ghc(8,2,0)+ (makeInstMod mn')+#endif+ (if isBase+ then mkBaseModule_ mn'+ else makeMod mn')+ False+ gblEnv = IfGblEnv { if_rec_types = Nothing, if_doc = empty } in do hscEnv <- getSession maybe' <- liftIO $ initTcRnIf 'i' hscEnv gblEnv () iface
src/IDE/StrippedPrefs.hs view
@@ -50,7 +50,7 @@ defaultPrefs = Prefs { sourceDirectories = [] , unpackDirectory = Just ("~" </> configDirName </> "packageSources")- , retrieveURL = "http://www.leksah.org/"+ , retrieveURL = "http://leksah.github.io/" , retrieveStrategy = RetrieveThenBuild , serverPort = 11111 , endWithLastConn = True
+ src/IDE/Utils/CabalPlan.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Utils.CabalPlan+-- Copyright : 2016-2016 Herbert Valerio Riedel+-- License : GPL+--+-- | Parse plan.json files+--+-----------------------------------------------------------------------------++module IDE.Utils.CabalPlan (+ PlanJson(..)+ , PlanItem(..)+ , PID+ , unitIdToPackageId+) where++import GHC.Generics (Generic)+import Data.List (sortOn)+import qualified Data.Set as S (fromList, Set)+import qualified Data.Map as M (empty, Map, toList)+import Data.Text (Text)+import qualified Data.Text as T+ (breakOnEnd, init, all, null, Text, pack, unpack, splitOn)+import Data.Aeson (FromJSON(..), withObject, (.:), (.:?))+import Distribution.Package (PackageIdentifier, UnitId)+import Distribution.Text (display, simpleParse)+import Data.Maybe (fromMaybe)++-- $setup+-- >>> import Data.Aeson (eitherDecodeStrict')+-- >>> import qualified Data.ByteString.Char8 as BS (pack)++-- | Information cabal-install writes to the plan.json file+-- >>> :{+-- eitherDecodeStrict' (BS.pack+-- "{\+-- \ \"cabal-lib-version\" : \"1.24.0.0\",\+-- \ \"cabal-version\" : \"1.24.0.0\",\+-- \ \"install-plan\" : [\+-- \ {\+-- \ \"type\" : \"pre-existing\",\+-- \ \"components\" : {\+-- \ \"lib\" : {\+-- \ \"depends\" : [\+-- \ \"array-0.5.1.1\",\+-- \ \"base-4.9.0.0\"\+-- \ ]\+-- \ }\+-- \ },\+-- \ \"id\" : \"Cabal-1.24.0.0\"\+-- \ },\+-- \ {\+-- \ \"id\" : \"QuickCheck-2.9.1-ec9a1c39266d75ed2c3314f6e846a8f11853eff43fc45db79c7256d9bfd94602\",\+-- \ \"components\" : {\+-- \ \"lib\" : {\+-- \ \"depends\" : [\+-- \ \"base-4.9.0.0\",\+-- \ \"containers-0.5.7.1\",\+-- \ \"random-1.1-fe6ccf72ebd63a2d68570bb45b42bd08df5570c6151cb9af54907d40ef9af454\"\+-- \ ]\+-- \ }\+-- \ },\+-- \ \"flags\" : {\+-- \ \"templatehaskell\" : true\+-- \ },\+-- \ \"type\" : \"configured\"\+-- \ }\+-- \ ]\+-- \}") :: Either String PlanJson+-- :}+-- Right (PlanJson {pjPlan = [PlanItem {piId = "Cabal-1.24.0.0", piType = "pre-existing", piComps = [(ComponentLib,fromList ["array-0.5.1.1","base-4.9.0.0"])]},PlanItem {piId = "QuickCheck-2.9.1-ec9a1c39266d75ed2c3314f6e846a8f11853eff43fc45db79c7256d9bfd94602", piType = "configured", piComps = [(ComponentLib,fromList ["base-4.9.0.0","containers-0.5.7.1","random-1.1-fe6ccf72ebd63a2d68570bb45b42bd08df5570c6151cb9af54907d40ef9af454"])]}]})+data PlanJson = PlanJson+ { pjPlan :: [PlanItem]+ , pjCabalVersion :: String+ , pjCabalLibVersion :: String+ , pjCompilerId :: Maybe String+ , pjOS :: Maybe String+ , pjArch :: Maybe String+ } deriving Show++instance FromJSON PlanJson where+ parseJSON = withObject "PlanJson" $ \o ->+ PlanJson <$> o .: "install-plan"+ <*> o .: "cabal-version"+ <*> o .: "cabal-lib-version"+ <*> o .:? "compiler-id"+ <*> o .:? "os"+ <*> o .:? "arch"++type PID = Text++data PlanItem = PlanItem+ { piId :: !PID+ , piType :: !Text+ , piComps :: [(Component, S.Set PID)]+ -- flags+ } deriving Show++instance FromJSON PlanItem where+ parseJSON = withObject "PlanItem" $ \o ->+ PlanItem <$> o .: "id"+ <*> o .: "type"+ <*> (doComps . fromMaybe M.empty <$> o .:? "components")+ where+ doComps :: M.Map Text CompInfo -> [(Component, S.Set PID)]+ doComps m = sortOn fst [ (toComp k, S.fromList v) | (k,CompInfo v) <- M.toList m ]++data CompInfo = CompInfo [PID]++instance FromJSON CompInfo where+ parseJSON = withObject "CompInfo" $ \o -> CompInfo <$> o .: "depends"++-- | Component of a package+--+-- NB: a similiar type exists in cabal's codebase+data Component =+ ComponentLib+ | ComponentSubLib !Text+ | ComponentExe !Text+ | ComponentTest !Text+ | ComponentBench !Text+ | ComponentSetup+ deriving (Show, Eq, Ord, Generic)++toComp :: Text -> Component+toComp t0 = case T.splitOn ":" t0 of+ ["lib"] -> ComponentLib+ ["lib",n] -> ComponentSubLib n+ ["exe",n] -> ComponentExe n+ ["bench",n] -> ComponentBench n+ ["test",n] -> ComponentTest n+ ["setup"] -> ComponentSetup+ _ -> error "IDE.Utils.CabalPlan.toComp"++-- |+-- >>> display <$> (unitIdToPackageId =<< simpleParse "base-4.9.0.0")+-- Just "base-4.9.0.0"+-- >>> display <$> (unitIdToPackageId =<< simpleParse "QuickCheck-2.9.1-ec9a1c39266d75ed2c3314f6e846a8f11853eff43fc45db79c7256d9bfd94602")+-- Just "QuickCheck-2.9.1"+unitIdToPackageId :: UnitId -> Maybe PackageIdentifier+unitIdToPackageId = (>>= simpleParse . T.unpack) . takePackageId . T.pack . display++takePackageId :: T.Text -> Maybe T.Text+takePackageId t+ | T.null pfx = Nothing+ | T.all (`elem` ("0123456789." :: String)) sfx = Just t -- assume hash-less+ | T.all (`elem` ("0123456789abcdef" :: String)) sfx = Just (T.init pfx)+ | otherwise = Nothing+ where+ (pfx, sfx) = T.breakOnEnd "-" t
+ src/IDE/Utils/CabalProject.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Utils.CabalProject+-- Copyright : 2016-2016 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.Utils.CabalProject (+ findProjectRoot+ , projectPackages+ , getCabalProjectPackages+) where++import Prelude hiding (readFile)+import System.Directory (doesFileExist, getHomeDirectory)+import System.FilePath (takeDirectory, isDrive, (</>))+import Control.Exception (catch, SomeException(..))+import System.IO.Strict (readFile)++findProjectRoot :: FilePath -> IO FilePath+findProjectRoot curdir = do++ -- Copied from cabal-install as it is not exposed+ -- and until features like `cabal run` exist for `cabal new-build`+ homedir <- getHomeDirectory++ -- Search upwards. If we get to the users home dir or the filesystem root,+ -- then use the current dir+ let probe dir | isDrive dir || dir == homedir+ = return curdir -- implicit project root+ probe dir = do+ exists <- doesFileExist (dir </> "cabal.project")+ if exists+ then return dir -- explicit project root+ else probe (takeDirectory dir)++ probe curdir+ --TODO: [nice to have] add compat support for old style sandboxes++-- |+-- >>> :{+-- projectPackages $ unlines+-- [ "something befor"+-- , "--comment"+-- , "packages:"+-- , "--comment2"+-- , " package1"+-- , ""+-- , " "+-- , " --comment3"+-- , " package2 --comment4"+-- , "notpackage"+-- , " also notpackage" ]+-- :}+-- ["package1","package2"]+projectPackages :: String -> [FilePath]+projectPackages = map (dropWhile (==' ')) .+ takeWhile (not . isNewSection) .+ drop 1 .+ dropWhile (/="packages:") .+ filter (not . null) .+ map (trimTrailing . dropComment) .+ lines+ where+ dropComment ('-':'-':_) = ""+ dropComment (x:xs) = x:dropComment xs+ dropComment "" = ""++ trimTrailing = reverse . dropWhile (==' ') . reverse++ isNewSection "" = False+ isNewSection (' ':_) = False+ isNewSection _ = True++getCabalProjectPackages :: FilePath -> IO [FilePath]+getCabalProjectPackages dir = do+ projectRoot <- findProjectRoot dir+ let projectFile = projectRoot </> "cabal.project"+ doesFileExist projectFile >>= \case+ False -> return []+ True -> (map (projectRoot </>) . projectPackages <$> readFile projectFile)+ `catch` (\(_ :: SomeException) -> return [])+
src/IDE/Utils/FileUtils.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.FileUtils@@ -39,10 +41,14 @@ , getCabalUserPackageDir , autoExtractCabalTarFiles , autoExtractTarFiles-, getInstalledPackageIds-, getInstalledPackageIds'+, getCabalPackages+, getInstalledPackages+, findProjectRoot+, cabalProjectBuildDir+, getPackageDBs' , getPackageDBs , figureOutGhcOpts+, figureOutGhcOpts' , figureOutHaddockOpts , allFilesWithExtensions , myCanonicalizePath@@ -52,15 +58,16 @@ import Prelude hiding (readFile) import System.FilePath (splitFileName, dropExtension, takeExtension,- combine, addExtension, (</>), normalise, splitPath, takeFileName,takeDirectory)+ combine, addExtension, (</>), normalise, splitPath, takeFileName,+ takeDirectory) import Distribution.ModuleName (toFilePath, ModuleName) import Control.Monad (when, foldM, filterM, forM) import Data.Maybe (mapMaybe, catMaybes) import Distribution.Simple.PreProcess.Unlit (unlit) import System.Directory- (canonicalizePath, doesDirectoryExist, doesFileExist,- setCurrentDirectory, getCurrentDirectory, getDirectoryContents,- createDirectory, getHomeDirectory)+ (getAppUserDataDirectory, canonicalizePath, doesDirectoryExist,+ doesFileExist, setCurrentDirectory, getCurrentDirectory,+ getDirectoryContents, createDirectory, getHomeDirectory) import Text.ParserCombinators.Parsec.Language (haskellDef, haskell) import qualified Text.ParserCombinators.Parsec.Token as P (GenTokenParser(..), TokenParser, identStart)@@ -69,9 +76,9 @@ (<?>), CharParser) import Data.Set (Set) import Data.List- (isPrefixOf, isSuffixOf, stripPrefix, nub)+ (isPrefixOf, isSuffixOf, stripPrefix, nub) import qualified Data.Set as Set (empty, fromList)-import Distribution.Package (PackageIdentifier)+import Distribution.Package (UnitId) import Data.Char (ord) import Distribution.Text (simpleParse, display) @@ -89,6 +96,11 @@ import Data.Monoid ((<>)) import Data.Text (Text) import Control.DeepSeq (deepseq)+import IDE.Utils.VersionUtils (ghcExeName, getDefaultGhcVersion)+import Data.Aeson (eitherDecodeStrict')+import IDE.Utils.CabalPlan (PlanJson(..), PlanItem(..))+import IDE.Utils.CabalProject (findProjectRoot)+import qualified Data.ByteString as BS (readFile) haskellSrcExts :: [FilePath] haskellSrcExts = ["hs","lhs","chs","hs.pp","lhs.pp","chs.pp","hsc"]@@ -165,8 +177,14 @@ savedConfigFile <- getConfigFilePathForSave fn doesFileExist savedConfigFile --getConfigFilePathForLoad :: FilePath -> Maybe FilePath -> FilePath -> IO FilePath+-- | Gets a config file. If the second argument is Nothing+-- first looks in the config dir (~/.leksah-x/), if it's not present+-- the data directory at the given location is checked (this is an argument+-- because `getDataDir` has to be called in Leksah code.+getConfigFilePathForLoad :: FilePath -- ^ Config filename with extension+ -> Maybe FilePath -- ^ Optional directory to check first+ -> FilePath -- ^ Data dir to check if not present in config dir+ -> IO FilePath getConfigFilePathForLoad fn mbFilePath dataDir = do mbCd <- case mbFilePath of Just p -> return (Just p)@@ -196,7 +214,7 @@ then do filesAndDirs <- getDirectoryContents filePath let filesAndDirs' = map (combine filePath)- $filter (\s -> s /= "." && s /= ".." && s /= "_darcs" && s /= "dist"+ $filter (\s -> s /= "." && s /= ".." && s /= "_darcs" && s /= "dist" && s /= "dist-newstyle" && s /= "Setup.lhs") filesAndDirs dirs <- filterM doesDirectoryExist filesAndDirs' files <- filterM doesFileExist filesAndDirs'@@ -288,9 +306,9 @@ moduleNameParser :: CharParser () Text moduleNameParser = do whiteSpace- many skipPreproc+ _ <- many skipPreproc whiteSpace- symbol "module"+ _ <- symbol "module" lexeme mident <?> "module identifier" @@ -298,8 +316,8 @@ skipPreproc = try (do whiteSpace- char '#'- many (noneOf "\n")+ _ <- char '#'+ _ <- many (noneOf "\n") return ()) <?> "preproc" @@ -347,7 +365,7 @@ getCabalUserPackageDir :: IO (Maybe FilePath) getCabalUserPackageDir = do- (!output,_) <- runTool' "cabal" ["help"] Nothing+ (!output,_) <- runTool' "cabal" ["help"] Nothing Nothing output `deepseq` 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@@ -380,7 +398,7 @@ command = "tar -zxf " ++ fn in do setCurrentDirectory dir handle <- runCommand command- waitForProcess handle+ _ <- waitForProcess handle return ()) decompressionTargets mapM_ autoExtractTarFiles' dirs@@ -399,9 +417,9 @@ createDirectory filePath return filePath -getSysLibDir :: IO FilePath-getSysLibDir = E.catch (do- (!output,_) <- runTool' "ghc" ["--print-libdir"] Nothing+getSysLibDir :: FilePath -> IO FilePath+getSysLibDir ver = E.catch (do+ (!output,_) <- runTool' (ghcExeName ver) ["--print-libdir"] Nothing Nothing let libDir = head [line | ToolOutput line <- output] libDir2 = if ord (T.last libDir) == 13 then T.init libDir@@ -409,46 +427,128 @@ output `deepseq` return $ normalise $ T.unpack libDir2 ) $ \ (e :: SomeException) -> error ("FileUtils>>getSysLibDir failed with " ++ show e) -getInstalledPackageIds :: [FilePath] -> IO [PackageIdentifier]-getInstalledPackageIds dirs = either (const []) id <$> getInstalledPackageIds' dirs+getStackPackages :: FilePath -> IO [(UnitId, [FilePath])]+getStackPackages dir = do+ packageDBs <- getStackPackageDBs dir+ (!output', _) <- runTool' "stack" ["--stack-yaml", T.pack (dir </> "stack.yaml"), "exec", "ghc-pkg", "--", "list", "--simple-output"] Nothing Nothing+ output' `deepseq` return $ map (,packageDBs) $ concatMap ghcPkgOutputToPackages output' -getInstalledPackageIds' :: [FilePath] -> IO (Either Text [PackageIdentifier])-getInstalledPackageIds' dirs = E.catch (do- (!output, _) <- runTool' "ghc-pkg" ["list", "--simple-output"] Nothing- pids <- output `deepseq` return $ concatMap names output+ghcPkgOutputToPackages :: ToolOutput -> [UnitId]+ghcPkgOutputToPackages (ToolOutput n) = mapMaybe (T.simpleParse . T.unpack) (T.words n)+ghcPkgOutputToPackages _ = []++getCabalPackages :: FilePath -> FilePath -> IO [(UnitId, [FilePath])]+getCabalPackages ghcVer dir = do+ packageDBs <- getCabalPackageDBs ghcVer dir+ projectRoot <- findProjectRoot dir+ (eitherDecodeStrict' <$> BS.readFile (projectRoot </> "dist-newstyle" </> "cache" </> "plan.json"))+ >>= \ case+ Left _ -> return []+ Right plan -> return . map (,packageDBs) $+ mapMaybe (T.simpleParse . T.unpack . piId) (pjPlan plan)++cabalProjectBuildDir :: FilePath -> IO (FilePath, FilePath -> FilePath)+cabalProjectBuildDir projectRoot = do+ let distNewstyle = projectRoot </> "dist-newstyle"+ planFile = distNewstyle </> "cache" </> "plan.json"+ defaultDir = (distNewstyle </> "build", const "build")+ doesFileExist planFile >>= \case+ False -> do+ debugM "leksah" $ "cabal plan not found : " <> planFile+ return defaultDir+ True ->+ (eitherDecodeStrict' <$> BS.readFile planFile)+ >>= \ case+ Right PlanJson { pjCabalVersion = v } | "1.24." `isPrefixOf` v ->+ return defaultDir+ Right PlanJson+ { pjCompilerId = Just compilerId+ , pjOS = Just os+ , pjArch = Just arch+ } -> return (distNewstyle </> "build" </> arch <> "-" <> os </> compilerId,+ \component -> "c" </> component </> "build")+ Right plan -> do+ errorM "leksah" $ "Unexpected cabal plan : " <> show plan+ return defaultDir+ Left err -> do+ errorM "leksah" $ "Error parsing cabal plan : " <> err+ return defaultDir++getPackages' :: [FilePath] -> IO [UnitId]+getPackages' packageDBs = do+ (!output', _) <- runTool' "ghc-pkg" (["list", "--simple-output"] ++ map (("--package-db="<>) . T.pack) packageDBs) Nothing Nothing+ output' `deepseq` return $ concatMap ghcPkgOutputToPackages output'++getPackages :: [FilePath] -> IO [(UnitId, [FilePath])]+getPackages packageDBs =+ map (,packageDBs) <$> getPackages' packageDBs++-- | Find the packages that the packages in the workspace+getInstalledPackages :: FilePath -> [FilePath] -> IO [(UnitId, [FilePath])]+getInstalledPackages ghcVer dirs = do+ globalDBs <- sequence [getGlobalPackageDB ghcVer, getStorePackageDB ghcVer]+ >>= filterM doesDirectoryExist+ globalPackages <- E.catch (getPackages globalDBs) $ \ (_ :: SomeException) -> return [] -- Do our best to get the stack package ids- stackPids <- forM dirs $ \dir -> E.catch (do- useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"- if useStack- then do- (!output', _) <- runTool' "stack" ["--stack-yaml", T.pack (dir </> "stack.yaml"), "exec", "ghc-pkg", "--", "list", "--simple-output"] Nothing- output' `deepseq` return $ concatMap names output'- else return []- ) $ \ (_ :: SomeException) -> return []- return . Right . nub $ pids ++ concat stackPids- ) $ \ (e :: SomeException) -> return . Left . T.pack $ show e- where- names (ToolOutput n) = mapMaybe (T.simpleParse . T.unpack) (T.words n)- names _ = []+ stackPackages <- forM dirs (\dir -> E.catch (do+ useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"+ if useStack+ then getStackPackages dir+ else do+ projectDB <- getProjectPackageDB ghcVer dir+ doesDirectoryExist projectDB >>= \case+ False -> return []+ True -> map (,globalDBs<>[projectDB]) <$> getPackages' [projectDB]+ ) $ \ (_ :: SomeException) -> return [])+ return . nub $ concat (globalPackages : stackPackages) -getPackageDBs :: [FilePath] -> IO [[FilePath]]-getPackageDBs dirs = do- dbs <- forM dirs $ \dir -> E.catch (do- useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"- if useStack- then do- (!output, _) <- runTool' "stack" ["--stack-yaml", T.pack (dir </> "stack.yaml"), "path", "--ghc-package-path"] Nothing- filterM doesDirectoryExist $ concatMap paths output- else return []- ) $ \ (_ :: SomeException) -> return []- return $ nub dbs+getGlobalPackageDB :: FilePath -> IO FilePath+getGlobalPackageDB ghcVersion = do+ ghcLibDir <- getSysLibDir ghcVersion+ return $ ghcLibDir </> "package.conf.d"++getStorePackageDB :: FilePath -> IO FilePath+getStorePackageDB ghcVersion = do+ cabalDir <- getAppUserDataDirectory "cabal"+ return $ cabalDir </> "store" </> "ghc-" ++ ghcVersion </> "package.db"++getProjectPackageDB :: FilePath -> FilePath -> IO FilePath+getProjectPackageDB ghcVersion dir = do+ projectRoot <- findProjectRoot dir+ return $ projectRoot </> "dist-newstyle/packagedb" </> "ghc-" ++ ghcVersion++getCabalPackageDBs :: FilePath -> FilePath -> IO [FilePath]+getCabalPackageDBs ghcVersion dir =+ sequence [getGlobalPackageDB ghcVersion, getStorePackageDB ghcVersion, getProjectPackageDB ghcVersion dir]+ >>= filterM doesDirectoryExist++getStackPackageDBs :: FilePath -> IO [FilePath]+getStackPackageDBs dir = do+ (!output, _) <- runTool' "stack" ["--stack-yaml", T.pack (dir </> "stack.yaml"), "path", "--ghc-package-path"] Nothing Nothing+ filterM doesDirectoryExist $ concatMap paths output where paths (ToolOutput n) = map T.unpack (T.splitOn ":" n) paths _ = [] +getPackageDBs' :: FilePath -> FilePath -> IO [FilePath]+getPackageDBs' ghcVersion dir =+ E.catch (do+ useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"+ if useStack+ then getStackPackageDBs dir+ else getCabalPackageDBs ghcVersion dir+ ) $ \ (_ :: SomeException) -> return []++getPackageDBs :: [FilePath] -> IO [[FilePath]]+getPackageDBs dirs = do+ ghcVersion <- getDefaultGhcVersion+ globalDBs <- sequence [getGlobalPackageDB ghcVersion, getStorePackageDB ghcVersion]+ >>= filterM doesDirectoryExist+ nub . (globalDBs:) <$> forM dirs (getPackageDBs' ghcVersion)+ figureOutHaddockOpts :: IO [Text] figureOutHaddockOpts = do- (!output,_) <- runTool' "cabal" ["haddock", "--with-haddock=leksahecho", "--executables"] Nothing+ (!output,_) <- runTool' "cabal" ["haddock", "--with-haddock=leksahecho", "--executables"] Nothing Nothing let opts = concat [words $ T.unpack l | ToolOutput l <- output] let res = filterOptGhc opts debugM "leksah-server" ("figureOutHaddockOpts " ++ show res)@@ -460,19 +560,30 @@ Nothing -> filterOptGhc r Just s' -> s' : filterOptGhc r -figureOutGhcOpts :: IO [Text]-figureOutGhcOpts = do+figureOutGhcOpts :: FilePath -> IO [Text]+figureOutGhcOpts dir = do debugM "leksah-server" "figureOutGhcOpts"- (!output,_) <- runTool' "cabal" ["build","--with-ghc=leksahecho","--with-ghcjs=leksahecho"] Nothing+ ghcVersion <- getDefaultGhcVersion+ packageDBs <- liftIO $ getPackageDBs' ghcVersion dir+ flags <- doesFileExist (dir </> "base.cabal") >>= \case+ True -> return ["-finteger-gmp", "-finteger-gmp2"]+ False -> return ["-f-overloaded-methods", "-f-overloaded-properties", "-f-overloaded-signals"]+ (!output,_) <- runTool' "cabal" ("configure" : flags <> map (("--package-db=" <>) . T.pack) packageDBs) (Just dir) Nothing+ output `deepseq` figureOutGhcOpts' dir++figureOutGhcOpts' :: FilePath -> IO [Text]+figureOutGhcOpts' dir = do+ debugM "leksah-server" "figureOutGhcOpts'"+ (!output,_) <- runTool' "cabal" ["build","--with-ghc=leksahecho","--with-ghcjs=leksahecho"] (Just dir) Nothing let res = case catMaybes [findMake $ T.unpack l | ToolOutput l <- output] of options:_ -> words options _ -> [] debugM "leksah-server" ("figureOutGhcOpts " ++ show res) output `deepseq` return $ map T.pack res- where- findMake :: String -> Maybe String- findMake [] = Nothing- findMake line@(_:xs) =- case stripPrefix "--make " line of- Nothing -> findMake xs- s -> s+ where+ findMake :: String -> Maybe String+ findMake [] = Nothing+ findMake line@(_:xs) =+ case stripPrefix "--make " line of+ Nothing -> findMake xs+ s -> s
src/IDE/Utils/GHCUtils.hs view
@@ -23,47 +23,27 @@ ) where import Distribution.Simple (withinRange,PackageIdentifier(..),Dependency(..))-#if MIN_VERSION_ghc(7,10,0)-import PackageConfig (sourcePackageIdString)+import PackageConfig (sourcePackageIdString, PackageConfig) import Distribution.Text (simpleParse) import Data.Maybe (fromJust)-#else-import qualified Distribution.InstalledPackageInfo as IPI (sourcePackageId)-#endif import GHC import DriverPipeline(preprocess) import StringBuffer (StringBuffer(..),hGetStringBuffer) import FastString (mkFastString) import Lexer (mkPState,ParseResult(..),getMessages,unP) import Outputable (ppr)-#if MIN_VERSION_ghc(7,2,0)-#if MIN_VERSION_ghc(7,6,0) import Bag (unitBag)-#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(..))-#endif-import PackageConfig (PackageConfig)+import Control.Monad (unless, void) import Data.Foldable (maximumBy) import qualified Parser as P (parseModule,parseHeader) import HscStats (ppSourceStats)-#if MIN_VERSION_ghc(7,2,0)-#if !MIN_VERSION_ghc(7,7,0)-import GhcMonad (Ghc(..))-#endif import SrcLoc (mkRealSrcLoc)-#else-import HscTypes (Ghc(..))-#endif import IDE.Utils.FileUtils (getSysLibDir)-#if MIN_VERSION_ghc(7,7,0)-import DynFlags (DumpFlag(..), gopt_set, PkgConfRef(..))+#if MIN_VERSION_ghc(8,2,0)+import DynFlags (DumpFlag(..), gopt_set, PkgConfRef(..), PackageDBFlag(..)) #else-import DynFlags (dopt_set, PkgConfRef(..))+import DynFlags (DumpFlag(..), gopt_set, PkgConfRef(..)) #endif import System.Log.Logger(debugM) import Control.Monad.IO.Class (MonadIO(..))@@ -72,76 +52,60 @@ import Data.Monoid ((<>)) import Data.Function (on) -#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 :: [Text] -> [GeneralFlag] -> [FilePath] -> (DynFlags -> Ghc a) -> IO a-#else-inGhcIO :: [Text] -> [DynFlag] -> [FilePath] -> (DynFlags -> Ghc a) -> IO a-#endif-inGhcIO flags' udynFlags dbs ghcAct = do+inGhcIO :: FilePath -> [Text] -> [GeneralFlag] -> [FilePath] -> (DynFlags -> Ghc a) -> IO a+inGhcIO libDir flags' udynFlags dbs 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 gopt_set dynflags udynFlags-#else- let dynflags' = foldl dopt_set dynflags udynFlags-#endif let dynflags'' = dynflags' { hscTarget = HscNothing, ghcMode = CompManager, ghcLink = NoLink,+#if MIN_VERSION_ghc(8,2,0)+ packageDBFlags = map (PackageDB . PkgConfFile) dbs ++ packageDBFlags dynflags'+#else extraPkgConfs = (map PkgConfFile dbs++) . extraPkgConfs dynflags'+#endif } dynflags''' <- parseGhcFlags dynflags'' (map (noLoc . T.unpack) flags') flags'- res <- defaultCleanupHandler dynflags''' $ do- setSessionDynFlags dynflags'''- getSessionDynFlags >>= ghcAct+ _ <- setSessionDynFlags dynflags'''+ res <- getSessionDynFlags >>= ghcAct unload return res where parseGhcFlags :: DynFlags -> [Located String] -> [Text] -> Ghc DynFlags parseGhcFlags dynflags flags_ _origFlags = do- (dynflags', rest, _) <- parseDynamicFlags dynflags flags_- if not (null rest)- then do- liftIO $ debugM "leksah-server" ("No dynamic GHC options: " ++ unwords (map unLoc rest))- return dynflags'- else return dynflags'+ (dynflags', rest, _) <- parseDynamicFlags dynflags flags_+ if not (null rest)+ then do+ liftIO $ debugM "leksah-server" ("No dynamic GHC options: " ++ unwords (map unLoc rest))+ return dynflags'+ else return dynflags' -- | Unload whatever is currently loaded. unload :: Ghc () unload = do setTargets []- load LoadAllTargets- return ()+ void $ load LoadAllTargets getInstalledPackageInfos :: Ghc [PackageConfig] getInstalledPackageInfos = do dflags1 <- getSessionDynFlags-#if !MIN_VERSION_ghc(7,6,0)- setSessionDynFlags $ dopt_set dflags1 Opt_ReadUserPackageConf-#endif case pkgDatabase dflags1 of Nothing -> return []+#if MIN_VERSION_ghc(8,0,0)+ Just fm -> return (fm >>= snd)+#else Just fm -> return fm+#endif findFittingPackages :: [Dependency] -> Ghc [PackageIdentifier] findFittingPackages dependencyList = do knownPackages <- getInstalledPackageInfos-#if MIN_VERSION_ghc(7,10,0) let packages = map (fromJust . simpleParse . sourcePackageIdString) knownPackages-#else- let packages = map IPI.sourcePackageId knownPackages-#endif return (concatMap (fittingKnown packages) dependencyList) where fittingKnown packages (Dependency dname versionRange) =@@ -169,38 +133,25 @@ Just b -> return b Nothing -> hGetStringBuffer src_filename -#if MIN_VERSION_ghc(7,2,0) let loc = mkRealSrcLoc (mkFastString src_filename) 1 0-#else- let loc = mkSrcLoc (mkFastString src_filename) 1 0-#endif case unP P.parseModule (mkPState dflags buf' loc) of { -#if MIN_VERSION_ghc(7,6,0) PFailed span' err -> do { let {errMsg = mkPlainErrMsg dflags span' err}; printBagOfErrors dflags (unitBag errMsg); return (Left errMsg); };-#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};+ let {ms@(warnings, errors) = getMessages pst+#if MIN_VERSION_ghc(8,2,0)+ dflags+#endif+ }; 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;-#endif -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1); dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;@@ -213,13 +164,11 @@ }} myParseHeader :: FilePath -> String -> [Text] -> IO (Either Text (DynFlags, HsModule RdrName))-myParseHeader fp _str opts = inGhcIO (opts++["-cpp"]) [] [] $ \ _dynFlags -> do+myParseHeader fp _str opts = do+ libDir <- getSysLibDir VERSION_ghc+ inGhcIO libDir (opts++["-cpp"]) [] [] $ \ _dynFlags -> do session <- getSession-#if MIN_VERSION_ghc(7,2,0) (dynFlags',fp') <- liftIO $ preprocess session (fp,Nothing)-#else- (dynFlags',fp') <- preprocess session (fp,Nothing)-#endif liftIO $ do stringBuffer <- hGetStringBuffer fp' parseResult <- myParseModuleHeader dynFlags' fp (Just stringBuffer)@@ -246,38 +195,21 @@ Just b -> return b Nothing -> hGetStringBuffer src_filename -#if MIN_VERSION_ghc(7,2,0) let loc = mkRealSrcLoc (mkFastString src_filename) 1 0-#else- let loc = mkSrcLoc (mkFastString src_filename) 1 0-#endif -#if MIN_VERSION_ghc(7,0,1) case unP P.parseHeader (mkPState dflags buf' loc) of {-#else- case unP P.parseHeader (mkPState buf' loc dflags) of {-#endif -#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};+ let {ms@(warnings, errors) = getMessages pst+#if MIN_VERSION_ghc(8,2,0)+ dflags+#endif+ }; 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;-#endif -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1); dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
src/IDE/Utils/Server.hs view
@@ -57,7 +57,7 @@ serverSocket server = do sock <- serverSocket' server setSocketOption sock ReuseAddr 1- bindSocket sock (serverAddr server)+ bind sock (serverAddr server) infoM "leksah-server" $ "Bind " ++ show (serverAddr server) listen sock maxListenQueue return (sock, server)
src/IDE/Utils/Tool.hs view
@@ -56,7 +56,7 @@ getChanContents, dupChan) import Control.Monad (when, unless) import Control.Monad.IO.Class (liftIO, MonadIO)-import Data.Maybe (maybeToList)+import Data.Maybe (fromMaybe) import System.Process (showCommandForUser, proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..), interruptProcessGroupOf,@@ -70,8 +70,8 @@ import System.Exit (ExitCode(..)) import System.IO (hClose, hFlush, Handle, hSetBuffering, BufferMode(..))-import System.Directory (doesFileExist)-import System.FilePath ((</>))+import System.Directory (getHomeDirectory)+import System.FilePath (dropTrailingPathSeparator) import Data.Conduit as C ((=$), ($$), ($=)) import qualified Data.Conduit as C@@ -90,6 +90,7 @@ import Data.Text (replace, Text) import Data.Monoid ((<>)) import Data.Text.IO (hPutStrLn)+import Data.List (stripPrefix) import Control.Arrow (Arrow(..)) #ifdef MIN_VERSION_unix import System.Posix.Signals@@ -102,9 +103,11 @@ | ToolPrompt Text | ToolExit ExitCode deriving(Eq, Show) +#if !MIN_VERSION_process(1,4,0) instance NFData ExitCode where rnf ExitSuccess = rnf () rnf (ExitFailure failureCode) = rnf failureCode+#endif instance NFData ToolOutput where rnf (ToolInput s) = rnf s@@ -147,17 +150,17 @@ interruptProcessGroupOf = interruptProcessGroup #endif -runTool' :: FilePath -> [Text] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle)-runTool' fp args mbDir = do+runTool' :: FilePath -> [Text] -> Maybe FilePath -> Maybe [(String,String)] -> IO ([ToolOutput], ProcessHandle)+runTool' fp args mbDir mbEnv = do debugM "leksah-server" $ "Start: " ++ show (fp, args)- (out,pid) <- runTool fp args mbDir+ (out,pid) <- runTool fp args mbDir mbEnv output <- runResourceT $ out $$ CL.consume- waitForProcess pid+ _ <- waitForProcess pid debugM "leksah-server" $ "End: " ++ show (fp, args) return (output,pid) -runTool :: MonadIO m => FilePath -> [Text] -> Maybe FilePath -> IO (C.Source m ToolOutput, ProcessHandle)-runTool executable arguments mbDir = do+runTool :: MonadIO m => FilePath -> [Text] -> Maybe FilePath -> Maybe [(String,String)] -> IO (C.Source m ToolOutput, ProcessHandle)+runTool executable arguments mbDir mbEnv = do #ifdef MIN_VERSION_unix -- As of GHC 7.10.1 both createProcess and the GHC GC use unblockSignals $ addSignal sigINT emptySignalSet@@ -167,6 +170,7 @@ std_out = CreatePipe, std_err = CreatePipe, cwd = mbDir,+ env = mbEnv, #ifdef MIN_VERSION_process_leksah new_group = True } #else@@ -174,7 +178,11 @@ #endif output <- getOutputNoPrompt inp out err pid return (do- C.yield . ToolInput . T.pack $ showCommandForUser executable (map T.unpack arguments)+ home <- liftIO getHomeDirectory+ let friendlyDir d = case stripPrefix home d of+ Just rest -> "~" <> rest+ Nothing -> d+ C.yield . ToolInput . ((fromMaybe "" (T.pack . friendlyDir . dropTrailingPathSeparator <$> mbDir) <> "$ ") <>) . T.pack $ showCommandForUser executable (map T.unpack arguments) output, pid) newToolState :: IO ToolState@@ -212,7 +220,7 @@ putMVar (toolProcessMVar tool) pid output <- getOutput clr inp out err pid - forkIO $ do+ _ <- forkIO $ do case initialCommand clr of Just cmd -> hPutStrLn inp cmd >> hFlush inp Nothing -> return ()@@ -257,7 +265,7 @@ 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)+ _ <- tryTakeMVar (currentToolCommand tool) return ((False, False, mbSyncCmd, n+1, promptLine), [ToolPrompt promptLine]) writeCommandOutput (RawToolOutput o@(ToolExit _)) s = do debugM "leksah-server" "Tool Exit"@@ -300,31 +308,31 @@ <?> "ghciParseFollowingPrompt" marker :: Int -> Text-marker n = "kMAKWRALZZbHdXfHUOAAYBB" <> T.pack (show n)+marker n = "kMAKWRALZ" <> T.pack (show n) parseMarker :: AP.Parser Int parseMarker = (do- AP.string $ T.pack "kMAKWRALZZbHdXfHUOAAYBB"+ _ <- AP.string $ T.pack "kMAKWRALZ" nums <- AP.takeWhile isDigit return . read $ T.unpack nums) <?> "parseMarker" ghciParseExpectedErrorCols :: AP.Parser () ghciParseExpectedErrorCols = (do- AP.string $ T.pack "0-"- AP.digit- AP.digit+ _ <- AP.string $ T.pack "0-"+ _ <- AP.digit+ _ <- AP.digit return ()) <|> (do- AP.string $ T.pack "1-"- AP.digit- AP.digit+ _ <- AP.string $ T.pack "1-"+ _ <- AP.digit+ _ <- AP.digit return ()) <|> (do- AP.string $ T.pack "0"+ _ <- AP.string $ T.pack "0" return ()) <|> (do- AP.string $ T.pack "1"+ _ <- AP.string $ T.pack "1" return ()) <?> "ghciParseExpectedErrorCols" @@ -335,17 +343,19 @@ ghciParseExpectedError :: AP.Parser (Text, Int) ghciParseExpectedError = ( first T.pack <$> AP.satisfy (/='\n') `manyTill'` (do- AP.string "\n<interactive>:"- AP.takeWhile1 isDigit- AP.string ":"+ _ <- AP.string "\n<interactive>:"+ _ <- AP.takeWhile1 isDigit+ _ <- AP.string ":" ghciParseExpectedErrorCols- AP.string ":"- AP.skipWhile (\c -> AP.isHorizontalSpace c || AP.isEndOfLine c)- AP.string "Not in scope: "- AP.char '`' <|> AP.char '‛' <|> AP.char '‘'- result <- parseMarker- AP.char '\'' <|> AP.char '’'- AP.string "\n"+ _ <- AP.string ":"+ _ <- AP.skipWhile (\c -> AP.isHorizontalSpace c || AP.isEndOfLine c)+ _ <- AP.string "Not in scope: " <|> AP.string "error: Variable not in scope: "+ result <- (do+ _ <- AP.char '`' <|> AP.char '‛' <|> AP.char '‘'+ m <- parseMarker+ _ <- AP.char '\'' <|> AP.char '’'+ return m) <|> parseMarker+ _ <- AP.string "\n" return result)) <?> "ghciParseExpectedError" @@ -392,10 +402,10 @@ hSetBuffering err NoBuffering mvar <- newEmptyMVar foundExpectedError <- liftIO newEmptyMVar- forkIO $ do+ _ <- forkIO $ do readError mvar err foundExpectedError putMVar mvar ToolErrClosed- forkIO $ do+ _ <- forkIO $ do readOutput mvar out foundExpectedError putMVar mvar ToolOutClosed return $ enumOutput mvar@@ -469,11 +479,12 @@ loop (counter+1) errSynced line (_, False, Just syncCmd) -> do liftIO $ do- debugM "leksah-server" $ "sendErrors - Sync " ++ T.unpack (syncCmd counter)- hPutStrLn inp $ syncCmd counter+ let errN = counter `rem` 10+ debugM "leksah-server" $ "sendErrors - Sync " ++ T.unpack (syncCmd errN)+ hPutStrLn inp $ syncCmd errN hFlush inp- waitForError counter- debugM "leksah-server" $ "sendErrors - Synced " ++ show counter+ waitForError errN+ debugM "leksah-server" $ "sendErrors - Synced " ++ show errN loop (counter+1) True line (_, True, Just _) -> do liftIO $ putMVar mvar $ RawToolOutput (ToolPrompt promptLine)@@ -493,7 +504,7 @@ fromRawOutput :: RawToolOutput -> [ToolOutput] fromRawOutput (RawToolOutput output) = [output]-fromRawOutput (_) = []+fromRawOutput _ = [] getOutputNoPrompt :: MonadIO m => Handle -> Handle -> Handle -> ProcessHandle -> IO (C.Source m ToolOutput) getOutputNoPrompt inp out err pid = do@@ -508,15 +519,13 @@ runInteractiveTool tool ghciCommandLineReader "ghci" flags Nothing return tool -newGhci :: FilePath -> Maybe Text -> [Text] -> C.Sink ToolOutput IO () -> IO ToolState-newGhci dir mbExe interactiveFlags startupOutputHandler = do- tool <- newToolState- writeChan (toolCommands tool) $- ToolCommand (":set " <> T.unwords interactiveFlags <> "\n:set prompt " <> ghciPrompt) "" startupOutputHandler- useStack <- doesFileExist $ dir </> "stack.yaml"- runInteractiveTool tool ghciCommandLineReader (if useStack then "stack" else "cabal")- ("repl" : maybeToList mbExe) (Just dir)- return tool+newGhci :: FilePath -> [Text] -> FilePath -> [Text] -> C.Sink ToolOutput IO () -> IO ToolState+newGhci executable arguments dir interactiveFlags startupOutputHandler = do+ tool <- newToolState+ writeChan (toolCommands tool) $+ ToolCommand (":set " <> T.unwords interactiveFlags <> "\n:set prompt " <> ghciPrompt) "" startupOutputHandler+ runInteractiveTool tool ghciCommandLineReader executable arguments (Just dir)+ return tool executeCommand :: ToolState -> Text -> Text -> C.Sink ToolOutput IO () -> IO () executeCommand tool command rawCommand handler =
src/IDE/Utils/VersionUtils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, BangPatterns, OverloadedStrings #-}+{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.VersionUtils@@ -15,21 +15,28 @@ module IDE.Utils.VersionUtils ( getHaddockVersion-, getGhcVersion+, getDefaultGhcVersion , getGhcInfo+, supportedGhcVersions+, ghcExeName ) where import IDE.Utils.Tool (ToolOutput(..), runTool') import Data.Char (ord)+import Data.List (nub) import System.Log.Logger (debugM) import Control.Exception as E (SomeException, catch) import qualified Data.Text as T (unlines, unpack, init, last) import Data.Text (Text) import Control.DeepSeq (deepseq)+import Data.Monoid ((<>)) -getGhcVersion :: IO FilePath-getGhcVersion = E.catch (do- (!output,_) <- runTool' "ghc" ["--numeric-version"] Nothing+supportedGhcVersions :: [FilePath]+supportedGhcVersions = nub ["7.10.3", "8.0.1", VERSION_ghc]++getDefaultGhcVersion :: IO FilePath+getDefaultGhcVersion = E.catch (do+ (!output,_) <- runTool' "ghc" ["--numeric-version"] Nothing Nothing let vers = head [l | ToolOutput l <- output] vers2 = if ord (T.last vers) == 13 then T.init vers@@ -38,15 +45,22 @@ output `deepseq` return $ T.unpack vers2 ) $ \ (e :: SomeException) -> error $ "FileUtils>>getGhcVersion failed with " ++ show e -getGhcInfo :: IO Text-getGhcInfo = E.catch (do- (!output,_) <- runTool' "ghc" ["--info"] Nothing+ghcExeName :: FilePath -> FilePath+#ifdef mingw32_HOST_OS+ghcExeName ver = "ghc-" <> ver <> ".exe"+#else+ghcExeName = ("ghc-" <>)+#endif++getGhcInfo :: FilePath -> IO Text+getGhcInfo ver = E.catch (do+ (!output,_) <- runTool' (ghcExeName ver) ["--info"] Nothing Nothing output `deepseq` return $ T.unlines [l | ToolOutput l <- output] ) $ \ (e :: SomeException) -> error $ "FileUtils>>getGhcInfo failed with " ++ show e getHaddockVersion :: IO Text getHaddockVersion = E.catch (do- (!output,_) <- runTool' "haddock" ["--version"] Nothing+ (!output,_) <- runTool' "haddock" ["--version"] Nothing Nothing let vers = head [l | ToolOutput l <- output] vers2 = if ord (T.last vers) == 13 then T.init vers
tests/TestTool.hs view
@@ -19,17 +19,16 @@ import System.Environment (getArgs) import System.Exit (exitWith, exitSuccess, exitFailure, ExitCode(..))+import System.FilePath ((</>))+import Data.Monoid ((<>)) import IDE.Utils.Tool (toolProcess, executeGhciCommand, ToolOutput(..), runTool', newGhci')-#ifdef MIN_VERSION_process_leksah-import IDE.System.Process (interruptProcessGroup, getProcessExitCode)-#else import System.Process (interruptProcessGroupOf, getProcessExitCode)-#endif import Test.HUnit ((@=?), (@?=), putTextToHandle, Counts(..), runTestTT, assertBool, runTestText, (~:), Testable(..), Test(..))+import Test.DocTest (doctest) import System.IO (hPutStr, stdout, hPutStrLn, stderr, hFlush) import qualified Data.Conduit.List as EL (consume) import Control.Concurrent@@ -39,8 +38,9 @@ import System.Log.Logger (setLevel, rootLoggerName, updateGlobalLogger) import System.Log (Priority(..))--runSelf' args = runTool' "dist/build/test-tool/test-tool" args Nothing+import IDE.Utils.CabalProject (findProjectRoot)+import System.Directory (getCurrentDirectory)+import qualified Data.Text as T (pack) -- stderr and stdout may not be in sync check output expected = do@@ -63,40 +63,42 @@ loop Nothing -> return () -sendTest testMVar test = do+sendTest testMVar test = liftIO $ putMVar testMVar $ Just test -doneTesting testMVar = do- liftIO $ putMVar testMVar $ Nothing+doneTesting testMVar =+ liftIO $ putMVar testMVar Nothing -tests = test [+tests testTool =+ let runSelf' args = runTool' testTool args Nothing Nothing+ in test [ "Exit Success" ~: do (output, _) <- runSelf' ["ExitSuccess"]- output `check` [ToolInput "dist/build/test-tool/test-tool ExitSuccess", ToolExit ExitSuccess],+ output `check` [ToolInput $ T.pack testTool <> " ExitSuccess", ToolExit ExitSuccess], "Exit Failure" ~: do (output, _) <- runSelf' ["Exit42"]- output `check` [ToolInput "dist/build/test-tool/test-tool Exit42", ToolExit (ExitFailure 42)],+ output `check` [ToolInput $ T.pack testTool <> " Exit42", ToolExit (ExitFailure 42)], "Single Blank Out Line" ~: do (output, _) <- runSelf' ["BlankLine", "StdOut"]- output `check` [ToolInput "dist/build/test-tool/test-tool BlankLine StdOut", ToolOutput "", ToolExit ExitSuccess],+ output `check` [ToolInput $ T.pack testTool <> " BlankLine StdOut", ToolOutput "", ToolExit ExitSuccess], "Single Blank Err Line" ~: do (output, _) <- runSelf' ["BlankLine", "StdErr"]- output `check` [ToolInput "dist/build/test-tool/test-tool BlankLine StdErr", ToolError "", ToolExit ExitSuccess],+ output `check` [ToolInput $ T.pack testTool <> " BlankLine StdErr", ToolError "", ToolExit ExitSuccess], "Hello Out" ~: do (output, _) <- runSelf' ["Hello", "StdOut"]- output `check` [ToolInput "dist/build/test-tool/test-tool Hello StdOut", ToolOutput "Hello World", ToolExit ExitSuccess],+ output `check` [ToolInput $ T.pack testTool <> " Hello StdOut", ToolOutput "Hello World", ToolExit ExitSuccess], "Hello Err" ~: do (output, _) <- runSelf' ["Hello", "StdErr"]- output `check` [ToolInput "dist/build/test-tool/test-tool Hello StdErr", ToolError "Hello World", ToolExit ExitSuccess],+ output `check` [ToolInput $ T.pack testTool <> " Hello StdErr", ToolError "Hello World", ToolExit ExitSuccess], "Both" ~: do (output, _) <- runSelf' ["ErrAndOut"]- output `check` [ToolInput "dist/build/test-tool/test-tool ErrAndOut", ToolError "Error", ToolOutput "Output", ToolExit ExitSuccess],+ output `check` [ToolInput $ T.pack testTool <> " ErrAndOut", ToolError "Error", ToolOutput "Output", ToolExit ExitSuccess], "Unterminated Out" ~: do (output, _) <- runSelf' ["Unterminated", "StdOut"]- output `check` [ToolInput "dist/build/test-tool/test-tool Unterminated StdOut", ToolOutput "Unterminated", ToolExit ExitSuccess],+ output `check` [ToolInput $ T.pack testTool <> " Unterminated StdOut", ToolOutput "Unterminated", ToolExit ExitSuccess], "Unterminated Err" ~: do (output, _) <- runSelf' ["Unterminated", "StdErr"]- output `check` [ToolInput "dist/build/test-tool/test-tool Unterminated StdErr", ToolError "Unterminated", ToolExit ExitSuccess],+ output `check` [ToolInput $ T.pack testTool <> " Unterminated StdErr", ToolError "Unterminated", ToolExit ExitSuccess], "GHCi Failed Sart" ~: do t <- newEmptyMVar tool <- newGhci' ["MissingFile.hs"] $ do@@ -135,7 +137,9 @@ sendTest t $ output `check` [ ToolInput "jfkdfjdkl", ToolError "",-#if __GLASGOW_HASKELL__ > 706+#if __GLASGOW_HASKELL__ >= 800+ ToolError "<interactive>:22:1: error: Variable not in scope: jfkdfjdkl",+#elif __GLASGOW_HASKELL__ > 706 ToolError "<interactive>:23:1: Not in scope: ‘jfkdfjdkl’", #elif __GLASGOW_HASKELL__ > 702 ToolError "<interactive>:23:1: Not in scope: `jfkdfjdkl'",@@ -161,7 +165,9 @@ ToolInput "", ToolInput "jfkdfjdkl", ToolError "",-#if __GLASGOW_HASKELL__ > 706+#if __GLASGOW_HASKELL__ >= 800+ ToolError "<interactive>:35:1: error: Variable not in scope: jfkdfjdkl",+#elif __GLASGOW_HASKELL__ > 706 ToolError "<interactive>:36:1: Not in scope: ‘jfkdfjdkl’", #elif __GLASGOW_HASKELL__ > 702 ToolError "<interactive>:38:1: Not in scope: `jfkdfjdkl'",@@ -215,15 +221,19 @@ ToolInput ":quit", ToolOutput "Leaving GHCi.", ToolExit ExitSuccess]+ doneTesting t runTests t] main :: IO () main = do+ projectRoot <- findProjectRoot =<< getCurrentDirectory+ let testTool = projectRoot </> "dist-newstyle/build" </> ("leksah-server-" <> VERSION_leksah_server)+ </> "build/test-tool/test-tool" args <- getArgs case args of [] -> do- updateGlobalLogger rootLoggerName (\ l -> setLevel DEBUG l)- (Counts{failures=failures}, _) <- runTestText (putTextToHandle stderr False) tests+ doctest ["-isrc", "src/IDE/Utils/CabalPlan.hs", "src/IDE/Utils/CabalProject.hs"] -- updateGlobalLogger rootLoggerName (\ l -> setLevel DEBUG l)+ (Counts{failures=failures}, _) <- runTestText (putTextToHandle stderr False) (tests testTool) if failures == 0 then exitSuccess else exitFailure