diff --git a/data/prefscoll.lkshp b/data/prefscoll.lkshp --- a/data/prefscoll.lkshp +++ b/data/prefscoll.lkshp @@ -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: diff --git a/leksah-server.cabal b/leksah-server.cabal --- a/leksah-server.cabal +++ b/leksah-server.cabal @@ -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 diff --git a/main/Collector.hs b/main/Collector.hs --- a/main/Collector.hs +++ b/main/Collector.hs @@ -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 <> " ") diff --git a/main/LeksahEcho.hs b/main/LeksahEcho.hs --- a/main/LeksahEcho.hs +++ b/main/LeksahEcho.hs @@ -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 diff --git a/src/IDE/Core/CTypes.hs b/src/IDE/Core/CTypes.hs --- a/src/IDE/Core/CTypes.hs +++ b/src/IDE/Core/CTypes.hs @@ -72,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 diff --git a/src/IDE/Core/Serializable.hs b/src/IDE/Core/Serializable.hs --- a/src/IDE/Core/Serializable.hs +++ b/src/IDE/Core/Serializable.hs @@ -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 diff --git a/src/IDE/HeaderParser.hs b/src/IDE/HeaderParser.hs --- a/src/IDE/HeaderParser.hs +++ b/src/IDE/HeaderParser.hs @@ -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) diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs --- a/src/IDE/Metainfo/InterfaceCollector.hs +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -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 diff --git a/src/IDE/Metainfo/PackageCollector.hs b/src/IDE/Metainfo/PackageCollector.hs --- a/src/IDE/Metainfo/PackageCollector.hs +++ b/src/IDE/Metainfo/PackageCollector.hs @@ -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 + + + diff --git a/src/IDE/Metainfo/SourceCollectorH.hs b/src/IDE/Metainfo/SourceCollectorH.hs --- a/src/IDE/Metainfo/SourceCollectorH.hs +++ b/src/IDE/Metainfo/SourceCollectorH.hs @@ -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 diff --git a/src/IDE/Metainfo/SourceDB.hs b/src/IDE/Metainfo/SourceDB.hs --- a/src/IDE/Metainfo/SourceDB.hs +++ b/src/IDE/Metainfo/SourceDB.hs @@ -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" diff --git a/src/IDE/Metainfo/WorkspaceCollector.hs b/src/IDE/Metainfo/WorkspaceCollector.hs --- a/src/IDE/Metainfo/WorkspaceCollector.hs +++ b/src/IDE/Metainfo/WorkspaceCollector.hs @@ -1,4 +1,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 diff --git a/src/IDE/StrippedPrefs.hs b/src/IDE/StrippedPrefs.hs --- a/src/IDE/StrippedPrefs.hs +++ b/src/IDE/StrippedPrefs.hs @@ -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 diff --git a/src/IDE/Utils/CabalPlan.hs b/src/IDE/Utils/CabalPlan.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/CabalPlan.hs @@ -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 diff --git a/src/IDE/Utils/CabalProject.hs b/src/IDE/Utils/CabalProject.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/CabalProject.hs @@ -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 []) + diff --git a/src/IDE/Utils/FileUtils.hs b/src/IDE/Utils/FileUtils.hs --- a/src/IDE/Utils/FileUtils.hs +++ b/src/IDE/Utils/FileUtils.hs @@ -1,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 diff --git a/src/IDE/Utils/GHCUtils.hs b/src/IDE/Utils/GHCUtils.hs --- a/src/IDE/Utils/GHCUtils.hs +++ b/src/IDE/Utils/GHCUtils.hs @@ -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) ; diff --git a/src/IDE/Utils/Server.hs b/src/IDE/Utils/Server.hs --- a/src/IDE/Utils/Server.hs +++ b/src/IDE/Utils/Server.hs @@ -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) diff --git a/src/IDE/Utils/Tool.hs b/src/IDE/Utils/Tool.hs --- a/src/IDE/Utils/Tool.hs +++ b/src/IDE/Utils/Tool.hs @@ -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:" - AP.takeWhile1 isDigit - AP.string ":" + _ <- AP.string "\n:" + _ <- 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 = diff --git a/src/IDE/Utils/VersionUtils.hs b/src/IDE/Utils/VersionUtils.hs --- a/src/IDE/Utils/VersionUtils.hs +++ b/src/IDE/Utils/VersionUtils.hs @@ -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 diff --git a/tests/TestTool.hs b/tests/TestTool.hs --- a/tests/TestTool.hs +++ b/tests/TestTool.hs @@ -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 ":22:1: error: Variable not in scope: jfkdfjdkl", +#elif __GLASGOW_HASKELL__ > 706 ToolError ":23:1: Not in scope: ‘jfkdfjdkl’", #elif __GLASGOW_HASKELL__ > 702 ToolError ":23:1: Not in scope: `jfkdfjdkl'", @@ -161,7 +165,9 @@ ToolInput "", ToolInput "jfkdfjdkl", ToolError "", -#if __GLASGOW_HASKELL__ > 706 +#if __GLASGOW_HASKELL__ >= 800 + ToolError ":35:1: error: Variable not in scope: jfkdfjdkl", +#elif __GLASGOW_HASKELL__ > 706 ToolError ":36:1: Not in scope: ‘jfkdfjdkl’", #elif __GLASGOW_HASKELL__ > 702 ToolError ":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