From ce61f38f4d966866c420ed82ce0f43061fa789f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 3 Jan 2015 00:32:32 +0100 Subject: [PATCH 001/207] Remove a bunch of dead code --- Language/Haskell/GhcMod/Logger.hs | 114 ++---------------------------- 1 file changed, 5 insertions(+), 109 deletions(-) diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 00f9625..5723e47 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -2,16 +2,15 @@ module Language.Haskell.GhcMod.Logger ( withLogger - , withLoggerTwice , checkErrorPrefix ) where -import Bag (Bag, bagToList, emptyBag, consBag, filterBag, unionBags) +import Bag (Bag, bagToList) import Control.Applicative ((<$>)) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) -import Data.List (isPrefixOf, find, nub, isInfixOf) -import Data.Maybe (fromMaybe, isJust) -import ErrUtils (ErrMsg, WarnMsg, errMsgShortDoc, errMsgExtraInfo, mkWarnMsg) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo) import Exception (ghandle) import GHC (DynFlags, SrcSpan, Severity(SevError)) import qualified GHC as G @@ -22,7 +21,7 @@ import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Convert (convert') import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types -import Outputable (PprStyle, SDoc, qualName, qualModule, mkErrStyle, neverQualify) +import Outputable (PprStyle, SDoc) import System.FilePath (normalise) ---------------------------------------------------------------- @@ -55,36 +54,6 @@ appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update ---------------------------------------------------------------- -data LogBag = LogBag (Bag WarnMsg) -newtype LogBagRef = LogBagRef (IORef LogBag) - -emptyLogBag :: LogBag -emptyLogBag = LogBag emptyBag - -newLogBagRef :: IO LogBagRef -newLogBagRef = LogBagRef <$> newIORef emptyLogBag - -readAndClearLogBagRef :: IOish m => LogBagRef -> GhcModT m (Bag WarnMsg) -readAndClearLogBagRef (LogBagRef ref) = do - LogBag b <- liftIO $ readIORef ref - liftIO $ writeIORef ref emptyLogBag - return b - -appendLogBagRef :: DynFlags -> LogBagRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () -appendLogBagRef df (LogBagRef ref) _ _ src style msg = modifyIORef ref update - where - qstyle = (qualName style, qualModule style) -#if __GLASGOW_HASKELL__ >= 706 - warnMsg = mkWarnMsg df src qstyle msg -#else - warnMsg = mkWarnMsg src qstyle msg -#endif - warnBag = consBag warnMsg emptyBag - update (LogBag b) = let (b1,b2) = mergeErrors df style b warnBag - in LogBag $ b1 `unionBags` b2 - ----------------------------------------------------------------- - -- | Set the session flag (e.g. "-Wall" or "-w:") then -- executes a body. Logged messages are returned as 'String'. -- Right is success and Left is failure. @@ -102,42 +71,6 @@ withLogger setDF body = ghandle sourceError $ do where setLogger logref df = Gap.setLogAction df $ appendLogRef df logref -withLoggerTwice :: IOish m - => (DynFlags -> DynFlags) - -> GhcModT m () - -> (DynFlags -> DynFlags) - -> GhcModT m () - -> GhcModT m (Either String String) -withLoggerTwice setDF1 body1 setDF2 body2 = do - err1 <- ghandle sourceErrorBag $ do - logref <- liftIO newLogBagRef - wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options - withDynFlags (setLogger logref . setDF1) $ - withCmdFlags wflags $ do - body1 - Right <$> readAndClearLogBagRef logref - err2 <- ghandle sourceErrorBag $ do - logref <- liftIO newLogBagRef - wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options - withDynFlags (setLogger logref . setDF2) $ - withCmdFlags wflags $ do - body2 - Right <$> readAndClearLogBagRef logref - -- Merge errors and warnings - dflags <- G.getSessionDynFlags - style <- getStyle - case (err1, err2) of - (Right b1, Right b2) -> do let (warn1,_) = mergeErrors dflags style b1 b2 - errAndWarnBagToStr Right emptyBag (warn1 `unionBags` b2) - (Left b1, Right b2) -> do let (err,warn) = mergeErrors dflags style b1 b2 - errAndWarnBagToStr Right err warn - (Right b1, Left b2) -> do let (err,warn) = mergeErrors dflags style b2 b1 - errAndWarnBagToStr Right err warn - (Left b1, Left b2) -> do let (err1',err2') = mergeErrors dflags style b1 b2 - errAndWarnBagToStr Right (err1' `unionBags` err2') emptyBag - where - setLogger logref df = Gap.setLogAction df $ appendLogBagRef df logref - ---------------------------------------------------------------- -- | Converting 'SourceError' to 'String'. @@ -154,39 +87,9 @@ errBagToStr' f err = do ret <- convert' (errBagToStrList dflags style err) return $ f ret -errAndWarnBagToStr :: IOish m => (String -> a) -> Bag ErrMsg -> Bag WarnMsg -> GhcModT m a -errAndWarnBagToStr f err warn = do - dflags <- G.getSessionDynFlags - -- style <- toGhcModT getStyle -#if __GLASGOW_HASKELL__ >= 706 - let style = mkErrStyle dflags neverQualify -#else - let style = mkErrStyle neverQualify -#endif - ret <- convert' $ nub (errBagToStrList dflags style err ++ warnBagToStrList dflags style warn) - return $ f ret - errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList -warnBagToStrList :: DynFlags -> PprStyle -> Bag WarnMsg -> [String] -warnBagToStrList dflag style = map (ppWarnMsg dflag style) . reverse . bagToList - -sourceErrorBag :: IOish m => SourceError -> GhcModT m (Either (Bag ErrMsg) (Bag WarnMsg)) -sourceErrorBag err = return $ Left (srcErrorMessages err) - -mergeErrors :: DynFlags -> PprStyle -> Bag ErrMsg -> Bag ErrMsg -> (Bag ErrMsg, Bag ErrMsg) -mergeErrors dflag style b1 b2 = - let b1Msgs = map (\err1 -> let m = ppWarnMsg dflag style err1 in (m, head $ lines m)) - (bagToList b1) - mustBeB2 = \err2 -> let msg2 = ppWarnMsg dflag style err2 - line2 = head $ lines msg2 - in not . isJust $ find (\(msg1, line1) -> msg1 == msg2 || (line1 == line2 && isHoleMsg line1)) b1Msgs - in (b1, filterBag mustBeB2 b2) - -isHoleMsg :: String -> Bool -isHoleMsg = isInfixOf "Found hole" - ---------------------------------------------------------------- ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String @@ -196,13 +99,6 @@ ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ (if null ext th msg = errMsgShortDoc err ext = showPage dflag style (errMsgExtraInfo err) -ppWarnMsg :: DynFlags -> PprStyle -> ErrMsg -> String -ppWarnMsg dflag style err = ppMsg spn G.SevWarning dflag style msg ++ (if null ext then "" else "\n" ++ ext) - where - spn = Gap.errorMsgSpan err - msg = errMsgShortDoc err - ext = showPage dflag style (errMsgExtraInfo err) - ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String ppMsg spn sev dflag style msg = prefix ++ cts where From 129fe92de297f4f7d48acd6bb7904ff52777508f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 12 Jan 2015 17:26:46 +0100 Subject: [PATCH 002/207] Improve error reporting for invalid command line arguments --- src/GHCMod.hs | 59 ++++++++++++++++++++++++++++++++++----------------- 1 file changed, 39 insertions(+), 20 deletions(-) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 1b5bad2..b0ebec6 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -6,8 +6,6 @@ import Config (cProjectVersion) import MonadUtils (liftIO) import Control.Applicative import Control.Monad -import Control.Exception ( SomeException(..), fromException, Exception - , Handler(..), catches, throw) import Data.Typeable (Typeable) import Data.Version (showVersion) import Data.Default @@ -15,6 +13,7 @@ import Data.List import Data.List.Split import Data.Maybe import Data.Char (isSpace) +import Exception import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal import Paths_ghc_mod @@ -227,27 +226,32 @@ ghcModiUsage = where indent = (" "++) - - - cmdUsage :: String -> String -> String -cmdUsage cmd s = +cmdUsage cmd realUsage = let -- Find command head - a = dropWhile (not . ((" - " ++ cmd) `isInfixOf`)) $ lines s + a = dropWhile (not . isCmdHead) $ lines realUsage -- Take til the end of the current command block b = flip takeWhile a $ \l -> - all isSpace l || (isIndented l && (isCurrCmdHead l || isNotCmdHead l)) + all isSpace l || (isIndented l && (isCmdHead l || isNotCmdHead l)) -- Drop extra newline from the end c = dropWhileEnd (all isSpace) b isIndented = (" " `isPrefixOf`) isNotCmdHead = ( not . (" - " `isPrefixOf`)) - isCurrCmdHead = ((" - " ++ cmd) `isPrefixOf`) + + containsAnyCmdHead s = ((" - ") `isInfixOf` s) + containsCurrCmdHead s = ((" - " ++ cmd) `isInfixOf` s) + isCmdHead s = + containsAnyCmdHead s && + or [ containsCurrCmdHead s + , any (cmd `isPrefixOf`) (splitOn " | " s) + ] unindent (' ':' ':' ':' ':l) = l unindent l = l in unlines $ unindent <$> c + ---------------------------------------------------------------- option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a @@ -321,7 +325,8 @@ handler = flip catches $ , Handler $ \(InvalidCommandLine e) -> do case e of Left cmd -> - exitError $ (cmdUsage cmd ghcModUsage) ++ "\n" + exitError $ "Usage for `"++cmd++"' command:\n\n" + ++ (cmdUsage cmd ghcModUsage) ++ "\n" ++ progName ++ ": Invalid command line form." Right msg -> exitError $ progName ++ ": " ++ msg ] @@ -535,23 +540,37 @@ withParseCmd spec action args = do (opts', rest) <- parseCommandArgs spec args <$> options withOptions (const opts') $ action rest +withParseCmd' :: (IOish m, ExceptionMonad m) + => String + -> [OptDescr (Options -> Options)] + -> ([String] -> GhcModT m a) + -> [String] + -> GhcModT m a +withParseCmd' cmd spec action args = + catchArgs cmd $ withParseCmd spec action args + +catchArgs :: (Monad m, ExceptionMonad m) => String -> m a -> m a +catchArgs cmd action = + action `gcatch` \(PatternMatchFail _) -> + throw $ InvalidCommandLine (Left cmd) + modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd, debugInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd :: IOish m => [String] -> GhcModT m String -modulesCmd = withParseCmd [] $ \[] -> modules -languagesCmd = withParseCmd [] $ \[] -> languages -flagsCmd = withParseCmd [] $ \[] -> flags -debugInfoCmd = withParseCmd [] $ \[] -> debugInfo -rootInfoCmd = withParseCmd [] $ \[] -> rootInfo +modulesCmd = withParseCmd' "modules" [] $ \[] -> modules +languagesCmd = withParseCmd' "lang" [] $ \[] -> languages +flagsCmd = withParseCmd' "flag" [] $ \[] -> flags +debugInfoCmd = withParseCmd' "debug" [] $ \[] -> debugInfo +rootInfoCmd = withParseCmd' "root" [] $ \[] -> rootInfo -- internal -bootCmd = withParseCmd [] $ \[] -> boot +bootCmd = withParseCmd' "boot" [] $ \[] -> boot -dumpSymbolCmd = withParseCmd [] $ \[tmpdir] -> dumpSymbol tmpdir -findSymbolCmd = withParseCmd [] $ \[sym] -> findSymbol sym -pkgDocCmd = withParseCmd [] $ \[mdl] -> pkgDoc mdl -lintCmd = withParseCmd s $ \[file] -> lint file +dumpSymbolCmd = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir +findSymbolCmd = withParseCmd' "find" [] $ \[sym] -> findSymbol sym +pkgDocCmd = withParseCmd' "doc" [] $ \[mdl] -> pkgDoc mdl +lintCmd = withParseCmd' "lint" s $ \[file] -> lint file where s = hlintArgSpec browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls where s = browseArgSpec From 0eaa3d23d8efbdb1cf39b96fa1448ac279156b20 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 12 Jan 2015 20:04:41 +0100 Subject: [PATCH 003/207] Fix documentation for `root` command --- src/GHCMod.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index b0ebec6..4dd99c4 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -182,12 +182,12 @@ ghcModUsage = \ -l\n\ \ Option to be passed to hlint.\n\ \\n\ - \ - root FILE\n\ - \ Try to find the project directory given FILE. For Cabal\n\ - \ projects this is the directory containing the cabal file, for\n\ - \ projects that use a cabal sandbox but have no cabal file this is the\n\ - \ directory containing the sandbox and otherwise this is the directory\n\ - \ containing FILE.\n\ + \ - root\n\ + \ Try to find the project directory. For Cabal projects this is the\n\ + \ directory containing the cabal file, for projects that use a cabal\n\ + \ sandbox but have no cabal file this is the directory containing the\n\ + \ cabal.sandbox.config file and otherwise this is the current\n\ + \ directory.\n\ \\n\ \ - doc MODULE\n\ \ Try finding the html documentation directory for the given MODULE.\n\ From 45d6b7d67ae11b05f08cc459ad07bf4dffd08ef9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 7 Feb 2015 15:23:00 +0100 Subject: [PATCH 004/207] Guess right sandbox pkg-db path on ghc version mismatch If cabal.sandbox.config contains a "package-db:" declaration with the wrong path and only the ghc version is wrong, for example: ``` package-db: /.cabal-sandbox/x86_64-linux-ghc-7.8.3-packages.conf.d ``` Even though the user is using 7.10.0.20141222 `cabal repl` will correct this and pass ``` -package-db /.cabal-sandbox/x86_64-linux-ghc-7.10.0.20141222-packages.conf.d ``` to ghci, so obviously Cabal/cabal-install is doing some magic. Conflicts: Language/Haskell/GhcMod/PathsAndFiles.hs --- Language/Haskell/GhcMod/PathsAndFiles.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 064d39e..88c61a0 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -1,9 +1,11 @@ {-# LANGUAGE BangPatterns, TupleSections #-} module Language.Haskell.GhcMod.PathsAndFiles where +import Config (cProjectVersion, cTargetPlatformString) import Control.Applicative import Control.Monad import Data.List +import Data.List.Split (splitOn) import Data.Char import Data.Maybe import Data.Traversable (traverse) @@ -92,7 +94,13 @@ getSandboxDb :: FilePath -- ^ Path to the cabal package root directory -> IO (Maybe FilePath) getSandboxDb d = do mConf <- traverse readFile =<< U.mightExist (d "cabal.sandbox.config") - return $ extractSandboxDbDir =<< mConf + return $ fixPkgDbVer <$> (extractSandboxDbDir =<< mConf) + + where + fixPkgDbVer dir = + case takeFileName dir == ghcSandboxPkgDbDir of + True -> dir + False -> takeDirectory dir ghcSandboxPkgDbDir -- | Extract the sandbox package db directory from the cabal.sandbox.config file. -- Exception is thrown if the sandbox config file is broken. @@ -112,5 +120,12 @@ setupConfigFile crdl = cradleRootDir crdl setupConfigPath setupConfigPath :: FilePath setupConfigPath = localBuildInfoFile defaultDistPref +ghcSandboxPkgDbDir :: String +ghcSandboxPkgDbDir = + targetPlatform ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d" + where + targetPlatform = display buildPlatform + packageCache :: String packageCache = "package.cache" + From 27c1eb1eb38b47319a99d994326d654c33572244 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 16 Jan 2015 15:46:58 +0100 Subject: [PATCH 005/207] Add custom Setup.hs code to warn users about unsupported environments --- Setup.hs | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 63 insertions(+), 1 deletion(-) diff --git a/Setup.hs b/Setup.hs index 9a994af..97e3cf5 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,64 @@ import Distribution.Simple -main = defaultMain +import Distribution.Simple.LocalBuildInfo + +import Control.Monad +import Control.Applicative +import Data.Version +import System.Process +import System.Exit +import Text.ParserCombinators.ReadP + +-- import Data.Monoid +-- import Distribution.Simple.Setup +-- import Distribution.Simple.InstallDirs +-- main = defaultMainWithHooks $ simpleUserHooks { +-- confHook = \desc cf -> do +-- print desc +-- print cf +-- (confHook simpleUserHooks) desc cf { +-- configProgSuffix = +-- configProgSuffix cf `mappend` toFlag (toPathTemplate "$compiler") +-- } +-- } + +main :: IO () +main = defaultMainWithHooks $ simpleUserHooks { + postConf = \args cf desc lbi -> do + -- I hope they never change this ;) + ["cabal-install", "version", _cabalInstallVer, "using", "version", cabalVer', "of", "the", "Cabal", "library"] <- words <$> readProcess "cabal" ["--version"] "" + + let + ghcVer = compilerVersion (compiler lbi) + cabalVer = parseVer cabalVer' + + -- ghc >= 7.10? + minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10") + + [libCabalVer] = [ ver | (_, PackageIdentifier pkg ver) + <- externalPackageDeps lbi + , pkg == PackageName "Cabal" ] + + if minGhc710 then + -- make sure Cabal versions are consistent + when (not $ cabalVer `sameMajorVersionAs` libCabalVer) $ do + putStrLn $ "Error: Cabal seems to have decided ghc-mod should be built using Cabal version "++showVersion libCabalVer++ " while the `cabal' executable in your PATH was built with Cabal version "++showVersion cabalVer++ ". This will lead to conflicts when running ghc-mod in any project where you use this `cabal' executable. Please compile ghc-mod using the same Cabal version as your `cabal' executable or recompile cabal-install using this version of the Cabal library. (See https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions )" + exitFailure + + else -- ghc < 7.10 + -- make sure Cabal version is < 1.22 + when (not $ cabalVer `earlierVersionThan` (parseVer "1.22")) $ do + putStrLn "Error: when ghc-mod is built with GHC version < 7.10 only Cabal < 1.22 is supported. (See https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions )" + exitFailure + + (postConf simpleUserHooks) args cf desc lbi + } + where + parseVer str = + case filter ((=="") . snd) $ readP_to_S parseVersion str of + [(ver, _)] -> ver + _ -> error $ "No parse (Ver) :(\n" ++ str ++ "\n" + + earlierVersionThan ver ver' = + ver `withinRange` earlierVersion ver' + sameMajorVersionAs ver ver' = + ver `withinRange` withinVersion (Version (take 2 $ versionBranch ver') []) From 2b4fd77c2804b4af6513ce16c04141f82054d194 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 16 Jan 2015 15:47:56 +0100 Subject: [PATCH 006/207] Add GHC-7.10 support --- Language/Haskell/GhcMod/Browse.hs | 4 +- Language/Haskell/GhcMod/CabalApi.hs | 75 ++------- Language/Haskell/GhcMod/CabalConfig.hs | 157 ++---------------- .../GhcMod/{ => CabalConfig}/Cabal16.hs | 2 +- .../GhcMod/{ => CabalConfig}/Cabal18.hs | 2 +- .../GhcMod/{ => CabalConfig}/Cabal21.hs | 2 +- Language/Haskell/GhcMod/CabalConfig/Ghc710.hs | 49 ++++++ .../Haskell/GhcMod/CabalConfig/PreGhc710.hs | 154 +++++++++++++++++ Language/Haskell/GhcMod/Convert.hs | 2 +- Language/Haskell/GhcMod/FillSig.hs | 38 ++++- Language/Haskell/GhcMod/Find.hs | 21 +-- Language/Haskell/GhcMod/GHCApi.hs | 86 ---------- Language/Haskell/GhcMod/Gap.hs | 95 ++++++++++- Language/Haskell/GhcMod/Internal.hs | 2 - Language/Haskell/GhcMod/Modules.hs | 24 +-- Language/Haskell/GhcMod/Monad.hs | 10 +- ghc-mod.cabal | 41 +++-- src/GHCMod.hs | 4 +- test/CabalApiSpec.hs | 14 -- test/GhcApiSpec.hs | 29 ---- 20 files changed, 410 insertions(+), 401 deletions(-) rename Language/Haskell/GhcMod/{ => CabalConfig}/Cabal16.hs (97%) rename Language/Haskell/GhcMod/{ => CabalConfig}/Cabal18.hs (97%) rename Language/Haskell/GhcMod/{ => CabalConfig}/Cabal21.hs (98%) create mode 100644 Language/Haskell/GhcMod/CabalConfig/Ghc710.hs create mode 100644 Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs delete mode 100644 Language/Haskell/GhcMod/GHCApi.hs delete mode 100644 test/GhcApiSpec.hs diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index b5fc4aa..5efe157 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -13,7 +13,7 @@ import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Typ import qualified GHC as G import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified) -import Language.Haskell.GhcMod.Gap +import Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Monad (GhcModT, options) import Language.Haskell.GhcMod.Target (setTargetFiles) import Language.Haskell.GhcMod.Types @@ -127,7 +127,7 @@ tyType typ && not (G.isClassTyCon typ) = Just "data" | G.isNewTyCon typ = Just "newtype" | G.isClassTyCon typ = Just "class" - | G.isSynTyCon typ = Just "type" + | Gap.isSynTyCon typ = Just "type" | otherwise = Nothing removeForAlls :: Type -> Type diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index fc56adb..701e5b4 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -4,33 +4,27 @@ module Language.Haskell.GhcMod.CabalApi ( getCompilerOptions , parseCabalFile , cabalAllBuildInfo - , cabalDependPackages , cabalSourceDirs - , cabalAllTargets , cabalConfigDependencies ) where import Language.Haskell.GhcMod.CabalConfig import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets, - toModuleString) +import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, mkGHCCompilerId) import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Types import MonadUtils (liftIO) import Control.Applicative ((<$>)) import qualified Control.Exception as E -import Control.Monad (filterM) import Data.Maybe (maybeToList) import Data.Set (fromList, toList) -import Distribution.Package (Dependency(Dependency) - , PackageName(PackageName)) +import Distribution.Package (PackageName(PackageName)) import qualified Distribution.Package as C -import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable) +import Distribution.PackageDescription (PackageDescription, BuildInfo) import qualified Distribution.PackageDescription as P import Distribution.PackageDescription.Configuration (finalizePackageDescription) import Distribution.PackageDescription.Parse (readPackageDescription) -import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..)) import Distribution.Simple.Program as C (ghcProgram) import Distribution.Simple.Program.Types (programName, programFindVersion) import Distribution.System (buildPlatform) @@ -78,7 +72,7 @@ parseCabalFile :: (IOish m, MonadError GhcModError m) -> FilePath -> m PackageDescription parseCabalFile cradle file = do - cid <- liftIO getGHCId + cid <- mkGHCCompilerId <$> liftIO getGHCVersion epgd <- liftIO $ readPackageDescription silent file flags <- cabalConfigFlags cradle case toPkgDesc cid flags epgd of @@ -93,6 +87,14 @@ parseCabalFile cradle file = do where PackageName name = C.pkgName (P.package pd) +getGHCVersion :: IO Version +getGHCVersion = do + mv <- programFindVersion C.ghcProgram silent (programName C.ghcProgram) + case mv of + -- TODO: MonadError it up + Nothing -> E.throwIO $ userError "ghc not found" + Just v -> return v + ---------------------------------------------------------------- getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption] @@ -130,15 +132,6 @@ cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI ---------------------------------------------------------------- --- | Extracting package names of dependency. -cabalDependPackages :: [BuildInfo] -> [PackageBaseName] -cabalDependPackages bis = uniqueAndSort pkgs - where - pkgs = map getDependencyPackageName $ concatMap P.targetBuildDepends bis - getDependencyPackageName (Dependency (PackageName nm) _) = nm - ----------------------------------------------------------------- - -- | Extracting include directories for modules. cabalSourceDirs :: [BuildInfo] -> [IncludeDir] cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis @@ -147,47 +140,3 @@ cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis uniqueAndSort :: [String] -> [String] uniqueAndSort = toList . fromList - ----------------------------------------------------------------- - -getGHCId :: IO CompilerId -getGHCId = CompilerId GHC <$> getGHC - -getGHC :: IO Version -getGHC = do - mv <- programFindVersion C.ghcProgram silent (programName C.ghcProgram) - case mv of - -- TODO: MonadError it up - Nothing -> E.throwIO $ userError "ghc not found" - Just v -> return v - ----------------------------------------------------------------- - --- | Extracting all 'Module' 'FilePath's for libraries, executables, --- tests and benchmarks. -cabalAllTargets :: PackageDescription -> IO ([String],[String],[String],[String]) -cabalAllTargets pd = do - exeTargets <- mapM getExecutableTarget $ P.executables pd - testTargets <- mapM getTestTarget $ P.testSuites pd - return (libTargets,concat exeTargets,concat testTargets,benchTargets) - where - lib = case P.library pd of - Nothing -> [] - Just l -> P.libModules l - - libTargets = map toModuleString lib - benchTargets = benchmarkTargets pd - - getTestTarget :: TestSuite -> IO [String] - getTestTarget ts = - case P.testInterface ts of - (TestSuiteExeV10 _ filePath) -> do - let maybeTests = [p e | p <- P.hsSourceDirs $ P.testBuildInfo ts, e <- [filePath]] - liftIO $ filterM doesFileExist maybeTests - (TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName] - (TestSuiteUnsupported _) -> return [] - - getExecutableTarget :: Executable -> IO [String] - getExecutableTarget exe = do - let maybeExes = [p e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]] - liftIO $ filterM doesFileExist maybeExes diff --git a/Language/Haskell/GhcMod/CabalConfig.hs b/Language/Haskell/GhcMod/CabalConfig.hs index 2ab3024..79f48d7 100644 --- a/Language/Haskell/GhcMod/CabalConfig.hs +++ b/Language/Haskell/GhcMod/CabalConfig.hs @@ -1,66 +1,26 @@ -{-# LANGUAGE RecordWildCards, CPP #-} +{-# LANGUAGE CPP #-} --- | This module facilitates extracting information from Cabal's on-disk --- 'LocalBuildInfo' (@dist/setup-config@). +-- | This module abstracts extracting information from Cabal's on-disk +-- 'LocalBuildInfo' (@dist/setup-config@) for different version combinations of +-- Cabal and GHC. module Language.Haskell.GhcMod.CabalConfig ( - CabalConfig - , cabalConfigDependencies + cabalConfigDependencies , cabalConfigFlags ) where -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.Read -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.World - -import qualified Language.Haskell.GhcMod.Cabal16 as C16 -import qualified Language.Haskell.GhcMod.Cabal18 as C18 -import qualified Language.Haskell.GhcMod.Cabal21 as C21 - -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(x,y,z) 1 -#endif - -import Control.Applicative ((<$>)) -import Control.Monad (void, mplus, when) -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except () -#else -import Control.Monad.Error () -#endif -import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) -import Distribution.Package (InstalledPackageId(..) - , PackageIdentifier(..) - , PackageName(..)) +import Control.Applicative +import Distribution.Package (PackageIdentifier) import Distribution.PackageDescription (FlagAssignment) -import Distribution.Simple.LocalBuildInfo (ComponentName) -import MonadUtils (liftIO) ----------------------------------------------------------------- +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Error --- | 'Show'ed cabal 'LocalBuildInfo' string -type CabalConfig = String +#if __GLASGOW_HASKELL__ >= 710 +import Language.Haskell.GhcMod.CabalConfig.Ghc710 +#else +import Language.Haskell.GhcMod.CabalConfig.PreGhc710 +#endif --- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't --- exist run @cabal configure@ i.e. configure with default options like @cabal --- build@ would do. -getConfig :: (IOish m, MonadError GhcModError m) - => Cradle - -> m CabalConfig -getConfig cradle = do - outOfDate <- liftIO $ isSetupConfigOutOfDate cradle - when outOfDate configure - liftIO (readFile file) `tryFix` \_ -> - configure `modifyError'` GMECabalConfigure - where - file = setupConfigFile cradle - prjDir = cradleRootDir cradle - - configure :: (IOish m, MonadError GhcModError m) => m () - configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] -- | Get list of 'Package's needed by all components of the current package cabalConfigDependencies :: (IOish m, MonadError GhcModError m) @@ -70,83 +30,6 @@ cabalConfigDependencies :: (IOish m, MonadError GhcModError m) cabalConfigDependencies cradle thisPkg = configDependencies thisPkg <$> getConfig cradle --- | Extract list of depencenies for all components from 'CabalConfig' -configDependencies :: PackageIdentifier -> CabalConfig -> [Package] -configDependencies thisPkg config = map fromInstalledPackageId deps - where - deps :: [InstalledPackageId] - deps = case deps21 `mplus` deps18 `mplus` deps16 of - Right ps -> ps - Left msg -> error msg - - -- True if this dependency is an internal one (depends on the library - -- defined in the same package). - internal pkgid = pkgid == thisPkg - - -- Cabal >= 1.21 - deps21 :: Either String [InstalledPackageId] - deps21 = - map fst - <$> filterInternal21 - <$> (readEither =<< extractField config "componentsConfigs") - - filterInternal21 - :: [(ComponentName, C21.ComponentLocalBuildInfo, [ComponentName])] - -> [(InstalledPackageId, C21.PackageIdentifier)] - - filterInternal21 ccfg = [ (ipkgid, pkgid) - | (_,clbi,_) <- ccfg - , (ipkgid, pkgid) <- C21.componentPackageDeps clbi - , not (internal . packageIdentifierFrom21 $ pkgid) ] - - packageIdentifierFrom21 :: C21.PackageIdentifier -> PackageIdentifier - packageIdentifierFrom21 (C21.PackageIdentifier (C21.PackageName myName) myVersion) = - PackageIdentifier (PackageName myName) myVersion - - -- Cabal >= 1.18 && < 1.21 - deps18 :: Either String [InstalledPackageId] - deps18 = - map fst - <$> filterInternal - <$> (readEither =<< extractField config "componentsConfigs") - - filterInternal - :: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])] - -> [(InstalledPackageId, PackageIdentifier)] - - filterInternal ccfg = [ (ipkgid, pkgid) - | (_,clbi,_) <- ccfg - , (ipkgid, pkgid) <- C18.componentPackageDeps clbi - , not (internal pkgid) ] - - -- Cabal 1.16 and below - deps16 :: Either String [InstalledPackageId] - deps16 = map fst <$> filter (not . internal . snd) . nub <$> do - cbi <- concat <$> sequence [ extract "executableConfigs" - , extract "testSuiteConfigs" - , extract "benchmarkConfigs" ] - :: Either String [(String, C16.ComponentLocalBuildInfo)] - - return $ maybe [] C16.componentPackageDeps libraryConfig - ++ concatMap (C16.componentPackageDeps . snd) cbi - where - libraryConfig :: Maybe C16.ComponentLocalBuildInfo - libraryConfig = do - field <- find ("libraryConfig" `isPrefixOf`) (tails config) - clbi <- stripPrefix " = " field - if "Nothing" `isPrefixOf` clbi - then Nothing - else case readMaybe =<< stripPrefix "Just " clbi of - Just x -> x - Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi) - - extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)] - extract field = readConfigs field <$> extractField config field - - readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)] - readConfigs f s = case readEither s of - Right x -> x - Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")" -- | Get the flag assignment from the local build info of the given cradle cabalConfigFlags :: (IOish m, MonadError GhcModError m) @@ -157,15 +40,3 @@ cabalConfigFlags cradle = do case configFlags config of Right x -> return x Left msg -> throwError (GMECabalFlags (GMEString msg)) - --- | Extract the cabal flags from the 'CabalConfig' -configFlags :: CabalConfig -> Either String FlagAssignment -configFlags config = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags" - --- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable --- error message with lots of context on failure. -extractField :: CabalConfig -> String -> Either String String -extractField config field = - case extractParens <$> find (field `isPrefixOf`) (tails config) of - Just f -> Right f - Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config) diff --git a/Language/Haskell/GhcMod/Cabal16.hs b/Language/Haskell/GhcMod/CabalConfig/Cabal16.hs similarity index 97% rename from Language/Haskell/GhcMod/Cabal16.hs rename to Language/Haskell/GhcMod/CabalConfig/Cabal16.hs index d36fc36..be9e7cf 100644 --- a/Language/Haskell/GhcMod/Cabal16.hs +++ b/Language/Haskell/GhcMod/CabalConfig/Cabal16.hs @@ -31,7 +31,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -- | ComponentLocalBuildInfo for Cabal <= 1.16 -module Language.Haskell.GhcMod.Cabal16 ( +module Language.Haskell.GhcMod.CabalConfig.Cabal16 ( ComponentLocalBuildInfo , componentPackageDeps ) where diff --git a/Language/Haskell/GhcMod/Cabal18.hs b/Language/Haskell/GhcMod/CabalConfig/Cabal18.hs similarity index 97% rename from Language/Haskell/GhcMod/Cabal18.hs rename to Language/Haskell/GhcMod/CabalConfig/Cabal18.hs index 94451a7..f60366b 100644 --- a/Language/Haskell/GhcMod/Cabal18.hs +++ b/Language/Haskell/GhcMod/CabalConfig/Cabal18.hs @@ -30,7 +30,7 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -- | ComponentLocalBuildInfo for Cabal >= 1.18 -module Language.Haskell.GhcMod.Cabal18 ( +module Language.Haskell.GhcMod.CabalConfig.Cabal18 ( ComponentLocalBuildInfo , componentPackageDeps , componentLibraries diff --git a/Language/Haskell/GhcMod/Cabal21.hs b/Language/Haskell/GhcMod/CabalConfig/Cabal21.hs similarity index 98% rename from Language/Haskell/GhcMod/Cabal21.hs rename to Language/Haskell/GhcMod/CabalConfig/Cabal21.hs index 164e5d6..bde56bc 100644 --- a/Language/Haskell/GhcMod/Cabal21.hs +++ b/Language/Haskell/GhcMod/CabalConfig/Cabal21.hs @@ -30,7 +30,7 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -- | ComponentLocalBuildInfo for Cabal >= 1.21 -module Language.Haskell.GhcMod.Cabal21 ( +module Language.Haskell.GhcMod.CabalConfig.Cabal21 ( ComponentLocalBuildInfo , PackageIdentifier(..) , PackageName(..) diff --git a/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs b/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs new file mode 100644 index 0000000..2f0b41c --- /dev/null +++ b/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs @@ -0,0 +1,49 @@ +module Language.Haskell.GhcMod.CabalConfig.Ghc710 ( + configDependencies + , configFlags + , getConfig + ) where + +import Control.Monad +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, externalPackageDeps) +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.Configure (getConfigStateFile) +import Distribution.Simple.Setup (configConfigurationsFlags) +import Distribution.PackageDescription (FlagAssignment) + +import MonadUtils (liftIO) + +import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Utils +import Language.Haskell.GhcMod.World + + +-- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't +-- exist run @cabal configure@ i.e. configure with default options like @cabal +-- build@ would do. +getConfig :: (IOish m, MonadError GhcModError m) + => Cradle + -> m LocalBuildInfo +getConfig cradle = do + outOfDate <- liftIO $ isSetupConfigOutOfDate cradle + when outOfDate configure + liftIO (getConfigStateFile file) `tryFix` \_ -> + configure `modifyError'` GMECabalConfigure + where + file = setupConfigFile cradle + prjDir = cradleRootDir cradle + + configure :: (IOish m, MonadError GhcModError m) => m () + configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] + +configDependencies :: a -> LocalBuildInfo -> [Package] +configDependencies _ lbi = + [ fromInstalledPackageId instPkgId + | (instPkgId, _) <- externalPackageDeps lbi ] + + +configFlags :: LocalBuildInfo -> Either String FlagAssignment +configFlags = Right . configConfigurationsFlags . LBI.configFlags diff --git a/Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs b/Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs new file mode 100644 index 0000000..f243487 --- /dev/null +++ b/Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE RecordWildCards, CPP #-} + +-- | This module facilitates extracting information from Cabal's on-disk +-- 'LocalBuildInfo' (@dist/setup-config@). +module Language.Haskell.GhcMod.CabalConfig.PreGhc710 ( + configDependencies + , configFlags + , getConfig + ) where + +import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.Read +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Utils +import Language.Haskell.GhcMod.World + +import qualified Language.Haskell.GhcMod.CabalConfig.Cabal16 as C16 +import qualified Language.Haskell.GhcMod.CabalConfig.Cabal18 as C18 +import qualified Language.Haskell.GhcMod.CabalConfig.Cabal21 as C21 + +#ifndef MIN_VERSION_mtl +#define MIN_VERSION_mtl(x,y,z) 1 +#endif + +import Control.Applicative ((<$>)) +import Control.Monad (void, mplus, when) +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except () +#else +import Control.Monad.Error () +#endif +import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) +import Distribution.Package (InstalledPackageId(..) + , PackageIdentifier(..) + , PackageName(..)) +import Distribution.PackageDescription (FlagAssignment) +import Distribution.Simple.LocalBuildInfo (ComponentName) +import MonadUtils (liftIO) + +---------------------------------------------------------------- + +-- | 'Show'ed cabal 'LocalBuildInfo' string +type CabalConfig = String + +-- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't +-- exist run @cabal configure@ i.e. configure with default options like @cabal +-- build@ would do. +getConfig :: (IOish m, MonadError GhcModError m) + => Cradle + -> m CabalConfig +getConfig cradle = do + outOfDate <- liftIO $ isSetupConfigOutOfDate cradle + when outOfDate configure + liftIO (readFile file) `tryFix` \_ -> + configure `modifyError'` GMECabalConfigure + where + file = setupConfigFile cradle + prjDir = cradleRootDir cradle + + configure :: (IOish m, MonadError GhcModError m) => m () + configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] + + +-- | Extract list of depencenies for all components from 'CabalConfig' +configDependencies :: PackageIdentifier -> CabalConfig -> [Package] +configDependencies thisPkg config = map fromInstalledPackageId deps + where + deps :: [InstalledPackageId] + deps = case deps21 `mplus` deps18 `mplus` deps16 of + Right ps -> ps + Left msg -> error msg + + -- True if this dependency is an internal one (depends on the library + -- defined in the same package). + internal pkgid = pkgid == thisPkg + + -- Cabal >= 1.21 + deps21 :: Either String [InstalledPackageId] + deps21 = + map fst + <$> filterInternal21 + <$> (readEither =<< extractField config "componentsConfigs") + + filterInternal21 + :: [(ComponentName, C21.ComponentLocalBuildInfo, [ComponentName])] + -> [(InstalledPackageId, C21.PackageIdentifier)] + + filterInternal21 ccfg = [ (ipkgid, pkgid) + | (_,clbi,_) <- ccfg + , (ipkgid, pkgid) <- C21.componentPackageDeps clbi + , not (internal . packageIdentifierFrom21 $ pkgid) ] + + packageIdentifierFrom21 :: C21.PackageIdentifier -> PackageIdentifier + packageIdentifierFrom21 (C21.PackageIdentifier (C21.PackageName myName) myVersion) = + PackageIdentifier (PackageName myName) myVersion + + -- Cabal >= 1.18 && < 1.21 + deps18 :: Either String [InstalledPackageId] + deps18 = + map fst + <$> filterInternal + <$> (readEither =<< extractField config "componentsConfigs") + + filterInternal + :: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])] + -> [(InstalledPackageId, PackageIdentifier)] + + filterInternal ccfg = [ (ipkgid, pkgid) + | (_,clbi,_) <- ccfg + , (ipkgid, pkgid) <- C18.componentPackageDeps clbi + , not (internal pkgid) ] + + -- Cabal 1.16 and below + deps16 :: Either String [InstalledPackageId] + deps16 = map fst <$> filter (not . internal . snd) . nub <$> do + cbi <- concat <$> sequence [ extract "executableConfigs" + , extract "testSuiteConfigs" + , extract "benchmarkConfigs" ] + :: Either String [(String, C16.ComponentLocalBuildInfo)] + + return $ maybe [] C16.componentPackageDeps libraryConfig + ++ concatMap (C16.componentPackageDeps . snd) cbi + where + libraryConfig :: Maybe C16.ComponentLocalBuildInfo + libraryConfig = do + field <- find ("libraryConfig" `isPrefixOf`) (tails config) + clbi <- stripPrefix " = " field + if "Nothing" `isPrefixOf` clbi + then Nothing + else case readMaybe =<< stripPrefix "Just " clbi of + Just x -> x + Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi) + + extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)] + extract field = readConfigs field <$> extractField config field + + readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)] + readConfigs f s = case readEither s of + Right x -> x + Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")" + +-- | Extract the cabal flags from the 'CabalConfig' +configFlags :: CabalConfig -> Either String FlagAssignment +configFlags config = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags" + +-- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable +-- error message with lots of context on failure. +extractField :: CabalConfig -> String -> Either String String +extractField config field = + case extractParens <$> find (field `isPrefixOf`) (tails config) of + Just f -> Right f + Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config) diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 0b53f3b..862a296 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-} +{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-} module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index ae7e0ea..8e6f3fa 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -31,6 +31,10 @@ import qualified HsPat as Ty import qualified Language.Haskell.Exts.Annotated as HE import Djinn.GHC +#if __GLASGOW_HASKELL__ >= 710 +import GHC (unLoc) +#endif + ---------------------------------------------------------------- -- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE ---------------------------------------------------------------- @@ -97,7 +101,11 @@ getSignature modSum lineNo colNo = do p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum -- Inspect the parse tree to find the signature case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of +#if __GLASGOW_HASKELL__ >= 710 + [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] -> +#else [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] -> +#endif -- We found a type signature return $ Just $ Signature loc (map G.unLoc names) ty [L _ (G.InstD _)] -> do @@ -238,12 +246,24 @@ class FnArgsInfo ty name | ty -> name, name -> ty where instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where getFnName dflag style name = showOccName dflag style $ Gap.occName name - getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) = getFnArgs iTy +#if __GLASGOW_HASKELL__ >= 710 + getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy)) +#else + getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) +#endif + = getFnArgs iTy + getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy where fnarg ty = case ty of - (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy +#if __GLASGOW_HASKELL__ >= 710 + (G.HsForAllTy _ _ _ _ (L _ iTy)) -> +#else + (G.HsForAllTy _ _ _ (L _ iTy)) -> +#endif + fnarg iTy + (G.HsParTy (L _ iTy)) -> fnarg iTy (G.HsFunTy _ _) -> True _ -> False @@ -478,7 +498,13 @@ getBindingsForRecPat (Ty.PrefixCon args) = getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) = M.union (getBindingsForPat a1) (getBindingsForPat a2) getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = - getBindingsForRecFields fields - where getBindingsForRecFields [] = M.empty - getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) = - M.union (getBindingsForPat a) (getBindingsForRecFields fs) + getBindingsForRecFields (map unLoc' fields) + where +#if __GLASGOW_HASKELL__ >= 710 + unLoc' = unLoc +#else + unLoc' = id +#endif + getBindingsForRecFields [] = M.empty + getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) = + M.union (getBindingsForPat a) (getBindingsForRecFields fs) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 37ba7fe..a848c3e 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -26,7 +26,9 @@ import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.Gap (listVisibleModules) import Name (getOccString) +import Module (moduleNameString, moduleName) import System.Directory (doesFileExist, getModificationTime) import System.FilePath ((), takeDirectory) import System.IO @@ -139,22 +141,17 @@ isOlderThan cache file = do -- | Browsing all functions in all system/user modules. getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])] getSymbolTable = do - ghcModules <- G.packageDbModules True - moduleInfos <- mapM G.getModuleInfo ghcModules - let modules = do - m <- ghcModules - let moduleName = G.moduleNameString $ G.moduleName m --- modulePkg = G.packageIdString $ G.modulePackageId m - return moduleName - + df <- G.getSessionDynFlags + let mods = listVisibleModules df + moduleInfos <- mapM G.getModuleInfo mods return $ collectModules - $ extractBindings `concatMap` (moduleInfos `zip` modules) + $ extractBindings `concatMap` (moduleInfos `zip` mods) -extractBindings :: (Maybe G.ModuleInfo, ModuleString) +extractBindings :: (Maybe G.ModuleInfo, G.Module) -> [(Symbol, ModuleString)] extractBindings (Nothing,_) = [] -extractBindings (Just inf,mdlname) = - map (\name -> (getOccString name, mdlname)) names +extractBindings (Just inf,mdl) = + map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names where names = G.modInfoExports inf diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs deleted file mode 100644 index 0f10545..0000000 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.GhcMod.GHCApi ( - ghcPkgDb - , package - , modules - , findModule - , moduleInfo - , localModuleInfo - , bindings - ) where - -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.Monad (GhcModT) -import Language.Haskell.GhcMod.Target (setTargetFiles) -import Language.Haskell.GhcMod.Types - -import Control.Applicative ((<$>)) -import Distribution.Package (InstalledPackageId(..)) -import qualified Data.Map as M -import GHC (DynFlags(..)) -import qualified GHC as G -import GhcMonad -import qualified Packages as G -import qualified Module as G -import qualified OccName as G - ----------------------------------------------------------------- --- get Packages,Modules,Bindings - -ghcPkgDb :: GhcMonad m => m PkgDb -ghcPkgDb = M.fromList <$> - maybe [] (map toKv . filterInternal) <$> pkgDatabase <$> G.getSessionDynFlags - where - toKv pkg = (fromInstalledPackageId $ G.installedPackageId pkg, pkg) - filterInternal = - filter ((/= InstalledPackageId "builtin_rts") . G.installedPackageId) - -package :: G.PackageConfig -> Package -package = fromInstalledPackageId . G.installedPackageId - -modules :: G.PackageConfig -> [ModuleString] -modules = map G.moduleNameString . G.exposedModules - -findModule :: ModuleString -> PkgDb -> [Package] -findModule m db = M.elems $ package `M.map` (containsModule `M.filter` db) - where - containsModule :: G.PackageConfig -> Bool - containsModule pkgConf = - G.mkModuleName m `elem` G.exposedModules pkgConf - - -ghcPkgId :: Package -> G.PackageId -ghcPkgId (name,_,_) = - -- TODO: Adding the package version too breaks 'findModule' for some reason - -- this isn't a big deal since in the common case where we're in a cabal - -- project we just use cabal's view of package dependencies anyways so we're - -- guaranteed to only have one version of each package exposed. However when - -- we're operating without a cabal project this will probaly cause trouble. - G.stringToPackageId name - -type Binding = String - --- | @moduleInfo mpkg module@. @mpkg@ should be 'Nothing' iff. moduleInfo --- should look for @module@ in the working directory. --- --- To map a 'ModuleString' to a package see 'findModule' -moduleInfo :: IOish m - => Maybe Package - -> ModuleString - -> GhcModT m (Maybe G.ModuleInfo) -moduleInfo mpkg mdl = do - let mdlName = G.mkModuleName mdl - mfsPkgId = G.packageIdFS . ghcPkgId <$> mpkg - loadLocalModule - G.findModule mdlName mfsPkgId >>= G.getModuleInfo - where - loadLocalModule = case mpkg of - Just _ -> return () - Nothing -> setTargetFiles [mdl] - -localModuleInfo :: IOish m => ModuleString -> GhcModT m (Maybe G.ModuleInfo) -localModuleInfo mdl = moduleInfo Nothing mdl - -bindings :: G.ModuleInfo -> [Binding] -bindings minfo = map (G.occNameString . G.getOccName) $ G.modInfoExports minfo diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index fbbadd0..24b511c 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -41,11 +41,17 @@ module Language.Haskell.GhcMod.Gap ( , getClass , occName , setFlags + , ghcVersion + , mkGHCCompilerId + , listVisibleModuleNames + , listVisibleModules + , Language.Haskell.GhcMod.Gap.isSynTyCon ) where import Control.Applicative hiding (empty) import Control.Monad (filterM) import CoreSyn (CoreExpr) +import Data.Version (parseVersion) import Data.List (intersperse) import Data.Maybe (catMaybes) import Data.Time.Clock (UTCTime) @@ -65,6 +71,9 @@ import PprTyThing import StringBuffer import TcType import Var (varType) +import Config (cProjectVersion) + +import Text.ParserCombinators.ReadP (readP_to_S) import qualified Distribution.PackageDescription as P import qualified InstEnv @@ -88,6 +97,19 @@ import Data.Convertible import RdrName (rdrNameOcc) #endif +import Distribution.Version +import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..)) +#if __GLASGOW_HASKELL__ >= 710 +import Distribution.Simple.Compiler (CompilerInfo(..), AbiTag(..)) +import Packages (listVisibleModuleNames, lookupModuleInAllPackages) +#endif + +#if __GLASGOW_HASKELL__ < 710 +import UniqFM (eltsUFM) +import Packages (exposedModules, exposed, pkgIdMap) +import PackageConfig (PackageConfig, packageConfigId) +#endif + #if __GLASGOW_HASKELL__ >= 704 import qualified Data.IntSet as I (IntSet, empty) import qualified Distribution.ModuleName as M (ModuleName,toFilePath) @@ -173,7 +195,11 @@ toStringBuffer = liftIO . stringToStringBuffer . unlines ---------------------------------------------------------------- fOptions :: [String] -#if __GLASGOW_HASKELL__ >= 704 +#if __GLASGOW_HASKELL__ >= 710 +fOptions = [option | (FlagSpec option _ _ _) <- fFlags] + ++ [option | (FlagSpec option _ _ _) <- fWarningFlags] + ++ [option | (FlagSpec option _ _ _) <- fLangFlags] +#elif __GLASGOW_HASKELL__ >= 704 fOptions = [option | (option,_,_) <- fFlags] ++ [option | (option,_,_) <- fWarningFlags] ++ [option | (option,_,_) <- fLangFlags] @@ -253,7 +279,12 @@ addPackageFlags :: [Package] -> DynFlags -> DynFlags addPackageFlags pkgs df = df { packageFlags = packageFlags df ++ expose `map` pkgs } where +#if __GLASGOW_HASKELL__ >= 710 + expose :: Package -> PackageFlag + expose pkg = ExposePackage (PackageIdArg $ showPkgId pkg) (ModRenaming True []) +#else expose pkg = ExposePackageId $ showPkgId pkg +#endif ---------------------------------------------------------------- @@ -445,7 +476,12 @@ type GLMatchI = LMatch Id #endif getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) -#if __GLASGOW_HASKELL__ >= 708 +#if __GLASGOW_HASKELL__ >= 710 +-- Instance declarations of sort 'instance F (G a)' +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc) +-- Instance declarations of sort 'instance F G' (no variables) +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc) +#elif __GLASGOW_HASKELL__ >= 708 -- Instance declarations of sort 'instance F (G a)' getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc) -- Instance declarations of sort 'instance F G' (no variables) @@ -464,7 +500,6 @@ occName :: RdrName -> OccName occName = rdrNameOcc #endif ----------------------------------------------------------------- ---------------------------------------------------------------- setFlags :: DynFlags -> DynFlags @@ -473,3 +508,57 @@ setFlags df = df `gopt_unset` Opt_SpecConstr -- consume memory if -O2 #else setFlags = id #endif + +---------------------------------------------------------------- + +ghcVersion :: Version +ghcVersion = + case readP_to_S parseVersion $ cProjectVersion of + [(ver, "")] -> ver + _ -> error "parsing ghc version(cProjectVersion) failed." + + +#if __GLASGOW_HASKELL__ >= 710 +mkGHCCompilerId :: Version -> Distribution.Simple.Compiler.CompilerInfo +-- TODO we should probably fill this out properly +mkGHCCompilerId v = + CompilerInfo (CompilerId GHC v) NoAbiTag Nothing Nothing Nothing +#else +mkGHCCompilerId :: Version -> CompilerId +mkGHCCompilerId v = CompilerId GHC v +#endif + +---------------------------------------------------------------- + + +#if __GLASGOW_HASKELL__ < 710 +-- Copied from ghc/InteractiveUI.hs +allExposedPackageConfigs :: DynFlags -> [PackageConfig] +allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df + +allExposedModules :: DynFlags -> [ModuleName] +allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df + +listVisibleModuleNames :: DynFlags -> [ModuleName] +listVisibleModuleNames = allExposedModules +#endif + +listVisibleModules :: DynFlags -> [GHC.Module] +listVisibleModules df = let +#if __GLASGOW_HASKELL__ >= 710 + modNames = listVisibleModuleNames df + mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ] +#else + pkgCfgs = allExposedPackageConfigs df + mods = [ mkModule pid modname | p <- pkgCfgs + , let pid = packageConfigId p + , modname <- exposedModules p ] +#endif + in mods + +isSynTyCon :: TyCon -> Bool +#if __GLASGOW_HASKELL__ >= 710 +isSynTyCon = GHC.isTypeSynonymTyCon +#else +isSynTyCon = GHC.isSynTyCon +#endif diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index d79378c..12311fd 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -13,9 +13,7 @@ module Language.Haskell.GhcMod.Internal ( , parseCabalFile , getCompilerOptions , cabalAllBuildInfo - , cabalDependPackages , cabalSourceDirs - , cabalAllTargets -- * Various Paths , ghcLibDir , ghcModExecutable diff --git a/Language/Haskell/GhcMod/Modules.hs b/Language/Haskell/GhcMod/Modules.hs index cea00d7..47fd76c 100644 --- a/Language/Haskell/GhcMod/Modules.hs +++ b/Language/Haskell/GhcMod/Modules.hs @@ -1,32 +1,14 @@ module Language.Haskell.GhcMod.Modules (modules) where import Control.Applicative ((<$>)) -import Control.Exception (SomeException(..)) -import Data.List (nub, sort) import qualified GHC as G import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Types -import Packages (pkgIdMap, exposedModules, sourcePackageId, display) -import UniqFM (eltsUFM) +import Language.Haskell.GhcMod.Gap (listVisibleModuleNames) +import Module (moduleNameString) ---------------------------------------------------------------- -- | Listing installed modules. modules :: IOish m => GhcModT m String -modules = do - opt <- options - convert opt . arrange opt <$> (getModules `G.gcatch` handler) - where - getModules = getExposedModules <$> G.getSessionDynFlags - getExposedModules = concatMap exposedModules' - . eltsUFM . pkgIdMap . G.pkgState - exposedModules' p = - map G.moduleNameString (exposedModules p) - `zip` - repeat (display $ sourcePackageId p) - arrange opt = nub . sort . map (dropPkgs opt) - dropPkgs opt (name, pkg) - | detailed opt = name ++ " " ++ pkg - | otherwise = name - handler (SomeException _) = return [] +modules = convert' =<< map moduleNameString . listVisibleModuleNames <$> G.getSessionDynFlags diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 3b3b697..cbc2880 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -221,22 +221,28 @@ initializeFlagsWithCradle opt c | otherwise = withSandbox where mCabalFile = cradleCabalFile c + cabal = isJust mCabalFile + ghcopts = ghcUserOptions opt + withCabal = do let Just cabalFile = mCabalFile pkgDesc <- parseCabalFile c cabalFile compOpts <- getCompilerOptions ghcopts c pkgDesc initSession CabalPkg opt compOpts + withSandbox = initSession SingleFile opt compOpts where importDirs = [".","..","../..","../../..","../../../..","../../../../.."] + pkgOpts = ghcDbStackOpts $ cradlePkgDbStack c + compOpts | null pkgOpts = CompilerOptions ghcopts importDirs [] | otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] [] - wdir = cradleCurrentDir c - rdir = cradleRootDir c + + (wdir, rdir) = (cradleCurrentDir c, cradleRootDir c) initSession :: GhcMonad m => Build diff --git a/ghc-mod.cabal b/ghc-mod.cabal index a6d87af..84b40ec 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -20,7 +20,7 @@ Description: The ghc-mod command is a backend command to enrich Category: Development Cabal-Version: >= 1.10 -Build-Type: Simple +Build-Type: Custom Data-Dir: elisp Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-check.el ghc-process.el ghc-command.el ghc-info.el @@ -63,11 +63,11 @@ Library Language.Haskell.GhcMod.Internal Other-Modules: Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Browse - Language.Haskell.GhcMod.Cabal16 - Language.Haskell.GhcMod.Cabal18 - Language.Haskell.GhcMod.Cabal21 - Language.Haskell.GhcMod.CabalApi + Language.Haskell.GhcMod.CabalConfig.Cabal16 + Language.Haskell.GhcMod.CabalConfig.Cabal18 + Language.Haskell.GhcMod.CabalConfig.Cabal21 Language.Haskell.GhcMod.CabalConfig + Language.Haskell.GhcMod.CabalApi Language.Haskell.GhcMod.CaseSplit Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Convert @@ -79,7 +79,6 @@ Library Language.Haskell.GhcMod.FillSig Language.Haskell.GhcMod.Find Language.Haskell.GhcMod.Flag - Language.Haskell.GhcMod.GHCApi Language.Haskell.GhcMod.GHCChoice Language.Haskell.GhcMod.Gap Language.Haskell.GhcMod.GhcPkg @@ -97,6 +96,13 @@ Library Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.World + + if impl(ghc >= 7.10) + Other-Modules: Language.Haskell.GhcMod.CabalConfig.Ghc710 + else + Other-Modules: Language.Haskell.GhcMod.CabalConfig.PreGhc710 + + Build-Depends: base >= 4.0 && < 5 , containers , deepseq @@ -122,11 +128,16 @@ Library , haskell-src-exts , text , djinn-ghc >= 0.0.2.2 - if impl(ghc >= 7.8) + if impl(ghc >= 7.10) Build-Depends: Cabal >= 1.18 - else + + if impl(ghc == 7.8.*) + Build-Depends: Cabal >= 1.18 && < 1.22 + + if impl(ghc < 7.8) Build-Depends: convertible , Cabal >= 1.10 && < 1.17 + if impl(ghc <= 7.4.2) -- Only used to constrain random to a version that still works with GHC 7.4 Build-Depends: random <= 1.0.1.1 @@ -189,6 +200,7 @@ Test-Suite spec Main-Is: Main.hs Hs-Source-Dirs: test, . Ghc-Options: -Wall + CPP-Options: -DSPEC=1 Type: exitcode-stdio-1.0 Other-Modules: BrowseSpec CabalApiSpec @@ -203,6 +215,7 @@ Test-Suite spec PathsAndFilesSpec Spec TestUtils + Build-Depends: base >= 4.0 && < 5 , containers , deepseq @@ -229,14 +242,20 @@ Test-Suite spec , haskell-src-exts , text , djinn-ghc >= 0.0.2.2 - if impl(ghc >= 7.8) + + if impl(ghc >= 7.10) Build-Depends: Cabal >= 1.18 - else + + if impl(ghc == 7.8.*) + Build-Depends: Cabal >= 1.18 && < 1.22 + + if impl(ghc < 7.8) Build-Depends: convertible , Cabal >= 1.10 && < 1.17 + if impl(ghc < 7.6) Build-Depends: executable-path - CPP-Options: -DSPEC=1 + Source-Repository head Type: git diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 4dd99c4..415a054 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -88,9 +88,6 @@ ghcModUsage = \\n\ \ - list [FLAGS...] | modules [FLAGS...]\n\ \ List all visible modules.\n\ - \ Flags:\n\ - \ -d\n\ - \ Also print the modules' package.\n\ \\n\ \ - lang\n\ \ List all known GHC language extensions.\n\ @@ -607,6 +604,7 @@ hlintArgSpec = [ option "h" ["hlintOpt"] "Option to be passed to hlint" $ reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o } ] + browseArgSpec :: [OptDescr (Options -> Options)] browseArgSpec = [ option "o" ["operators"] "Also print operators." $ diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index 67aa9f4..a5cba69 100644 --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -9,7 +9,6 @@ import Language.Haskell.GhcMod.Types import Test.Hspec import System.Directory import System.FilePath -import System.Process (readProcess) import Dir import TestUtils @@ -47,19 +46,6 @@ spec = do includeDirs res' `shouldBe` ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"] (pkgName `map` depPackages res') `shouldContain` ["Cabal"] - - describe "cabalDependPackages" $ do - it "extracts dependent packages" $ do - crdl <- findCradle' "test/data/" - pkgs <- cabalDependPackages . cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal") - pkgs `shouldBe` ["Cabal","base","template-haskell"] - it "uses non default flags" $ do - withDirectory_ "test/data/cabal-flags" $ do - crdl <- findCradle - _ <- readProcess "cabal" ["configure", "-ftest-flag"] "" - pkgs <- cabalDependPackages . cabalAllBuildInfo <$> runD (parseCabalFile crdl "cabal-flags.cabal") - pkgs `shouldBe` ["Cabal","base"] - describe "cabalSourceDirs" $ do it "extracts all hs-source-dirs" $ do crdl <- findCradle' "test/data/check-test-subdir" diff --git a/test/GhcApiSpec.hs b/test/GhcApiSpec.hs deleted file mode 100644 index 0368489..0000000 --- a/test/GhcApiSpec.hs +++ /dev/null @@ -1,29 +0,0 @@ -module GhcApiSpec where - -import Control.Applicative -import Data.List (sort) -import Language.Haskell.GhcMod.GHCApi -import Test.Hspec -import TestUtils - -import Dir - -spec :: Spec -spec = do - describe "findModule" $ do - it "finds Data.List in `base' and `haskell2010'" - $ withDirectory_ "test/data" $ runD $ do - pkgs <- findModule "Data.List" <$> ghcPkgDb - let pkgNames = pkgName `map` pkgs - liftIO $ pkgNames `shouldContain` ["base", "haskell2010"] - - describe "moduleInfo" $ do - it "works for modules from global packages (e.g. base:Data.List)" - $ withDirectory_ "test/data" $ runD $ do - Just info <- moduleInfo (Just ("base","","")) "Data.List" - liftIO $ sort (bindings info) `shouldContain` ["++"] - - it "works for local modules" - $ withDirectory_ "test/data" $ runD $ do - Just info <- moduleInfo Nothing "Baz" - liftIO $ bindings info `shouldContain` ["baz"] From bc476649edf90711c688f6c4d736d665b35284c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 4 Feb 2015 01:12:51 +0100 Subject: [PATCH 007/207] Add support for some crazy X-* fields to Setup.hs X-Install-Target: Since cabal doesn't have builtin support for installing executables to locations other than $bindir yet this allows me to install stuff into $libexec or any other directory. X-Build-Depends-Like: Duplicating the dependencies of the main library for every test suite is getting annoying this allows me to copy the final resolved external dependencies of a component. --- Setup.hs | 197 +++++++++++++++++++++++++++++++++++++++---------- SetupCompat.hs | 104 ++++++++++++++++++++++++++ 2 files changed, 260 insertions(+), 41 deletions(-) mode change 100644 => 100755 Setup.hs create mode 100644 SetupCompat.hs diff --git a/Setup.hs b/Setup.hs old mode 100644 new mode 100755 index 97e3cf5..cd6f34e --- a/Setup.hs +++ b/Setup.hs @@ -1,64 +1,179 @@ +#!/usr/bin/env runhaskell +{-# LANGUAGE RecordWildCards #-} import Distribution.Simple +import Distribution.Simple.Setup +import Distribution.Simple.Install +import Distribution.Simple.InstallDirs as ID import Distribution.Simple.LocalBuildInfo +import Distribution.PackageDescription -import Control.Monad +import Control.Arrow import Control.Applicative +import Control.Monad +import Data.List +import Data.Maybe import Data.Version +import Data.Monoid import System.Process import System.Exit +import System.FilePath import Text.ParserCombinators.ReadP --- import Data.Monoid --- import Distribution.Simple.Setup --- import Distribution.Simple.InstallDirs --- main = defaultMainWithHooks $ simpleUserHooks { --- confHook = \desc cf -> do --- print desc --- print cf --- (confHook simpleUserHooks) desc cf { --- configProgSuffix = --- configProgSuffix cf `mappend` toFlag (toPathTemplate "$compiler") --- } --- } +import SetupCompat main :: IO () main = defaultMainWithHooks $ simpleUserHooks { - postConf = \args cf desc lbi -> do - -- I hope they never change this ;) - ["cabal-install", "version", _cabalInstallVer, "using", "version", cabalVer', "of", "the", "Cabal", "library"] <- words <$> readProcess "cabal" ["--version"] "" + confHook = \(gpd, hbi) cf -> + xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf - let - ghcVer = compilerVersion (compiler lbi) - cabalVer = parseVer cabalVer' + , copyHook = xInstallTargetHook - -- ghc >= 7.10? - minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10") + , instHook = \pd lbi uh ifl -> + (instHook simpleUserHooks) pd lbi uh ifl - [libCabalVer] = [ ver | (_, PackageIdentifier pkg ver) - <- externalPackageDeps lbi - , pkg == PackageName "Cabal" ] + , postConf = sanityCheckCabalVersions + } - if minGhc710 then - -- make sure Cabal versions are consistent - when (not $ cabalVer `sameMajorVersionAs` libCabalVer) $ do - putStrLn $ "Error: Cabal seems to have decided ghc-mod should be built using Cabal version "++showVersion libCabalVer++ " while the `cabal' executable in your PATH was built with Cabal version "++showVersion cabalVer++ ". This will lead to conflicts when running ghc-mod in any project where you use this `cabal' executable. Please compile ghc-mod using the same Cabal version as your `cabal' executable or recompile cabal-install using this version of the Cabal library. (See https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions )" - exitFailure +xBuildDependsLike :: LocalBuildInfo -> LocalBuildInfo +xBuildDependsLike lbi = + let + cc = componentsConfigs lbi + pd = localPkgDescr lbi + deps = dependsMap lbi + in setComponentsConfigs lbi + [ (cn, updateClbi deps comp clbi, cdeps) + | (cn, clbi, cdeps) <- cc + , let comp = getComponent pd cn + ] - else -- ghc < 7.10 - -- make sure Cabal version is < 1.22 - when (not $ cabalVer `earlierVersionThan` (parseVer "1.22")) $ do - putStrLn "Error: when ghc-mod is built with GHC version < 7.10 only Cabal < 1.22 is supported. (See https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions )" - exitFailure - - (postConf simpleUserHooks) args cf desc lbi - } where - parseVer str = - case filter ((=="") . snd) $ readP_to_S parseVersion str of - [(ver, _)] -> ver - _ -> error $ "No parse (Ver) :(\n" ++ str ++ "\n" + updateClbi deps comp clbi = let + cpdeps = componentPackageDeps clbi + in clbi { + componentPackageDeps = cpdeps `union` otherDeps deps comp + } + dependsMap :: + LocalBuildInfo -> [(ComponentName, [(InstalledPackageId, PackageId)])] + dependsMap lbi = + second componentPackageDeps <$> allComponentsInBuildOrder lbi + + otherDeps deps comp = fromMaybe [] $ + flip lookup deps =<< read <$> lookup "x-build-depends-like" fields + where + fields = customFieldsBI (componentBuildInfo comp) + +xInstallTargetHook :: + PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () +xInstallTargetHook pd lbi uh cf = do + let (extended, regular) = partition (isJust . installTarget) (executables pd) + + let pd_regular = pd { executables = regular } + + flip mapM extended $ \exe -> do + putStrLn $ "extended " ++ show (exeName exe) + + let + idirtpl = installDirTemplates lbi + env = installDirsTemplateEnv idirtpl + libexecdir' = fromPathTemplate (libexecdir idirtpl) + + pd_extended = onlyExePackageDesc [exe] pd + install_target = fromJust $ installTarget exe + install_target' = ID.substPathTemplate env install_target + -- $libexec isn't a real thing :/ so we have to simulate it + install_target'' = substLibExec' libexecdir' install_target' + + let lbi' = lbi { + installDirTemplates = + (installDirTemplates lbi) { + bindir = install_target'' + } + } + + install pd_extended lbi' cf + + install pd_regular lbi cf + + where + installTarget :: Executable -> Maybe PathTemplate + installTarget exe = + toPathTemplate <$> lookup "x-install-target" (customFieldsBI $ buildInfo exe) + + substLibExec libexecdir "$libexecdir" = libexecdir + substLibExec _ comp = comp + + substLibExec' dir = + withPT $ + withSP $ map (substLibExec dir . dropTrailingPathSeparator) + + + withPT f pt = toPathTemplate $ f (fromPathTemplate pt) + withSP f p = joinPath $ f (splitPath p) + +onlyExePackageDesc exes pd = emptyPackageDescription { + package = package pd + , executables = exes + } + +parseVer str = + case filter ((=="") . snd) $ readP_to_S parseVersion str of + [(ver, _)] -> ver + _ -> error $ "No parse (Ver) :(\n" ++ str ++ "\n" + +sanityCheckCabalVersions args cf desc lbi = do + (cabalInstallVer, cabalVer) <- getCabalExecVer + + let + ghcVer = compilerVersion (compiler lbi) + -- ghc >= 7.10? + minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10") + + when minGhc710 $ do + let cabalHelperCabalVer = compCabalVer CLibName + + when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $ + failCabalVersionDifferent cabalVer cabalHelperCabalVer + + -- carry on as usual + (postConf simpleUserHooks) args cf desc lbi + + where earlierVersionThan ver ver' = ver `withinRange` earlierVersion ver' sameMajorVersionAs ver ver' = ver `withinRange` withinVersion (Version (take 2 $ versionBranch ver') []) + + compCabalVer comp = let + clbi = getComponentLocalBuildInfo lbi comp + + [cabalVer] = + [ ver | (_, PackageIdentifier pkg ver) <- componentPackageDeps clbi + , pkg == PackageName "Cabal" ] + in cabalVer + + +getCabalExecVer = do + ["cabal-install", "version", cabalInstallVer, "using", "version", cabalVer, "of", "the", "Cabal", "library"] <- words <$> readProcess "cabal" ["--version"] "" + return (parseVer cabalInstallVer, parseVer cabalVer) + +failCabalVersionDifferent cabalVer libCabalVer = + putStrLn rerr >> exitFailure + where + replace :: String -> String -> String -> String + replace _ _ [] = [] + replace n r h@(h':hs) + | map snd (n `zip` h ) == n = r ++ replace n r (drop (length n) h) + | otherwise = h':replace n r hs + + rerr = replace "X.XX.X.X" (showVersion libCabalVer) $ + replace "Y.YY.Y.Y" (showVersion cabalVer) err + err = "\ +\Error: Cabal seems to have decided ghc-mod should be built using Cabal\n\ +\X.XX.X.X while the `cabal' executable in your PATH was built with Cabal\n\ +\Y.YY.Y.Y. This will lead to conflicts when running ghc-mod in any project\n\ +\where you use this `cabal' executable. Please compile ghc-mod using the same\n\ +\Cabal version as your `cabal' executable or recompile cabal-install using\n\ +\this version of the Cabal library.\n\ +\\n\ +\See: https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions\n" diff --git a/SetupCompat.hs b/SetupCompat.hs new file mode 100644 index 0000000..1082532 --- /dev/null +++ b/SetupCompat.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE CPP, RecordWildCards, StandaloneDeriving #-} +module SetupCompat where + +import Control.Monad.State.Strict +import Data.List +import Data.Maybe +import Data.Functor +import Data.Function +import Distribution.Simple.LocalBuildInfo +import Distribution.PackageDescription + +#if __GLASGOW_HASKELL__ <= 706 +componentsConfigs :: + LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] +componentsConfigs LocalBuildInfo {..} = + (maybe [] (\c -> [(CLibName, c, [])]) libraryConfig) + ++ ((\(n, clbi) -> (CExeName n, clbi, [])) <$> executableConfigs) + ++ ((\(n, clbi) -> (CTestName n, clbi, [])) <$> testSuiteConfigs) + ++ ((\(n, clbi) -> (CBenchName n, clbi, [])) <$> benchmarkConfigs) + +getComponent :: PackageDescription -> ComponentName -> Component +getComponent pkg cname = + case lookupComponent pkg cname of + Just cpnt -> cpnt + Nothing -> missingComponent + where + missingComponent = + error $ "internal error: the package description contains no " + ++ "component corresponding to " ++ show cname + +lookupComponent :: PackageDescription -> ComponentName -> Maybe Component +lookupComponent pkg CLibName = + fmap CLib $ library pkg +lookupComponent pkg (CExeName name) = + fmap CExe $ find ((name ==) . exeName) (executables pkg) +lookupComponent pkg (CTestName name) = + fmap CTest $ find ((name ==) . testName) (testSuites pkg) +lookupComponent pkg (CBenchName name) = + fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) + +-- We're lying here can't be bothered to order these +allComponentsInBuildOrder :: LocalBuildInfo + -> [(ComponentName, ComponentLocalBuildInfo)] +allComponentsInBuildOrder lbi = + [ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ] + +getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo +getComponentLocalBuildInfo lbi cname = + case [ clbi + | (cname', clbi, _) <- componentsConfigs lbi + , cname == cname' ] of + [clbi] -> clbi + _ -> missingComponent + where + missingComponent = + error $ "internal error: there is no configuration data " + ++ "for component " ++ show cname + +deriving instance (Ord ComponentName) + +setComponentsConfigs + :: LocalBuildInfo + -> [(ComponentName, ComponentLocalBuildInfo, a)] + -> LocalBuildInfo +setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs + where +-- gcs :: [ [(ComponentLocalBuildInfo, ComponentName, a)] ] + gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` fst3) cs + + fst3 (x,_,_) = x + + sameKind CLibName CLibName = True + sameKind CLibName _ = False + sameKind (CExeName _) (CExeName _) = True + sameKind (CExeName _) _ = False + sameKind (CTestName _) (CTestName _) = True + sameKind (CTestName _) _ = False + sameKind (CBenchName _) (CBenchName _) = True + sameKind (CBenchName _) _ = False + + setClbis [(CLibName, clbi, _)] = + get >>= \lbi -> put $ lbi {libraryConfig = Just clbi} + + setClbis cs@((CExeName _, _, _):_) = + let cfg = (\((CExeName n), clbi, _) -> (n, clbi)) <$> cs in + get >>= \lbi -> put $ lbi {executableConfigs = cfg } + + setClbis cs@((CTestName _, _, _):_) = + let cfg = (\((CTestName n), clbi, _) -> (n, clbi)) <$> cs in + get >>= \lbi -> put $ lbi {testSuiteConfigs = cfg } + + setClbis cs@((CBenchName _, _, _):_) = + let cfg = (\((CBenchName n), clbi, _) -> (n, clbi)) <$> cs in + get >>= \lbi -> put $ lbi {benchmarkConfigs = cfg } + +#else + +setComponentsConfigs + :: LocalBuildInfo + -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] + -> LocalBuildInfo +setComponentsConfigs lbi cs = lbi { componentsConfigs = cs } + +#endif From 11562b4fe7b041df32016629767860dcc2e5e614 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 4 Feb 2015 01:15:52 +0100 Subject: [PATCH 008/207] Cleanup cabal file using extentions --- ghc-mod.cabal | 55 ++++++++++----------------------------------------- 1 file changed, 10 insertions(+), 45 deletions(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 84b40ec..9b0eead 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -55,6 +55,10 @@ Extra-Source-Files: ChangeLog test/data/subdir1/subdir2/dummy test/data/.cabal-sandbox/packages/00-index.tar +Flag cabal-122 + Default: True + Manual: False + Library Default-Language: Haskell2010 GHC-Options: -Wall @@ -128,16 +132,13 @@ Library , haskell-src-exts , text , djinn-ghc >= 0.0.2.2 - if impl(ghc >= 7.10) - Build-Depends: Cabal >= 1.18 - - if impl(ghc == 7.8.*) - Build-Depends: Cabal >= 1.18 && < 1.22 - if impl(ghc < 7.8) Build-Depends: convertible , Cabal >= 1.10 && < 1.17 - + else + Build-Depends: Cabal >= 1.18 + if flag(cabal-122) + Build-Depends: Cabal >= 1.22 if impl(ghc <= 7.4.2) -- Only used to constrain random to a version that still works with GHC 7.4 Build-Depends: random <= 1.0.1.1 @@ -216,45 +217,9 @@ Test-Suite spec Spec TestUtils - Build-Depends: base >= 4.0 && < 5 - , containers - , deepseq - , directory - , filepath - , ghc - , ghc-paths - , ghc-syb-utils - , hlint >= 1.7.1 - , io-choice - , monad-journal >= 0.4 - , old-time - , pretty - , process - , syb - , temporary - , time - , transformers - , transformers-base - , mtl >= 2.0 - , monad-control - , hspec >= 1.8.2 - , split - , haskell-src-exts - , text - , djinn-ghc >= 0.0.2.2 + Build-Depends: hspec + X-Build-Depends-Like: CLibName - if impl(ghc >= 7.10) - Build-Depends: Cabal >= 1.18 - - if impl(ghc == 7.8.*) - Build-Depends: Cabal >= 1.18 && < 1.22 - - if impl(ghc < 7.8) - Build-Depends: convertible - , Cabal >= 1.10 && < 1.17 - - if impl(ghc < 7.6) - Build-Depends: executable-path Source-Repository head From 417cacbf8141fcef8c6d330a0bc34f42fef8c41c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 7 Feb 2015 16:40:22 +0100 Subject: [PATCH 009/207] Fix finding sandbox in sandbox only projects --- Language/Haskell/GhcMod/Cradle.hs | 2 +- Language/Haskell/GhcMod/GhcPkg.hs | 7 +-- Language/Haskell/GhcMod/PathsAndFiles.hs | 73 ++++++++++++++++++------ 3 files changed, 57 insertions(+), 25 deletions(-) diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index 94ee836..a5e652f 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -46,7 +46,7 @@ cabalCradle wdir = do sandboxCradle :: FilePath -> IO Cradle sandboxCradle wdir = do - Just sbDir <- getSandboxDb wdir + Just sbDir <- findCabalSandboxDir wdir pkgDbStack <- getPackageDbStack sbDir tmpDir <- newTempDir sbDir return Cradle { diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index 969acda..56dc123 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -29,11 +29,8 @@ getPackageDbStack :: FilePath -- ^ Project Directory (where the -- cabal.sandbox.config file would be if it -- exists) -> IO [GhcPkgDb] -getPackageDbStack cdir = do - mSDir <- getSandboxDb cdir - return $ [GlobalDb] ++ case mSDir of - Nothing -> [UserDb] - Just db -> [PackageDb db] +getPackageDbStack cdir = + ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 88c61a0..4bef50d 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -31,31 +31,66 @@ type FileName = String -- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile' -- or 'GMETooManyCabalFiles' findCabalFile :: FilePath -> IO (Maybe FilePath) -findCabalFile directory = do - -- Look for cabal files in @dir@ and all it's parent directories - dcs <- getCabalFiles `zipMapM` parents directory +findCabalFile dir = do + dcs <- findFileInParentsP isCabalFile dir -- Extract first non-empty list, which represents a directory with cabal -- files. case find (not . null) $ uncurry appendDir `map` dcs of Just [] -> throw $ GMENoCabalFile Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs a -> return $ head <$> a - where - appendDir :: DirPath -> [FileName] -> [FilePath] - appendDir dir fs = (dir ) `map` fs --- | @getCabalFiles dir@. Find all files ending in @.cabal@ in @dir@. -getCabalFiles :: DirPath -> IO [FileName] -getCabalFiles dir = - filterM isCabalFile =<< getDirectoryContents dir - where - isCabalFile f = do - exists <- doesFileExist $ dir f - return (exists && takeExtension' f == ".cabal") +-- | +-- >>> isCabalFile "/home/user/.cabal" +-- False +isCabalFile :: FilePath -> Bool +isCabalFile f = takeExtension' f == ".cabal" - takeExtension' p = if takeFileName p == takeExtension p - then "" - else takeExtension p +-- | +-- >>> takeExtension' "/some/dir/bla.cabal" +-- ".cabal" +-- +-- >>> takeExtension' "some/reldir/bla.cabal" +-- ".cabal" +-- +-- >>> takeExtension' "bla.cabal" +-- ".cabal" +-- +-- >>> takeExtension' ".cabal" +-- "" +takeExtension' :: FilePath -> String +takeExtension' p = + if takeFileName p == takeExtension p + then "" -- just ".cabal" is not a valid cabal file + else takeExtension p + +-- | @findFileInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all +-- it's parent directories. +findFileInParentsP :: (FilePath -> Bool) -> FilePath + -> IO [(DirPath, [FileName])] +findFileInParentsP p dir = + getFilesP p `zipMapM` parents dir + +-- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@. +getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName] +getFilesP p dir = filterM p' =<< getDirectoryContents dir + where + p' fn = do + (p fn && ) <$> doesFileExist (dir fn) + +findCabalSandboxDir :: FilePath -> IO (Maybe FilePath) +findCabalSandboxDir dir = do + dss <- findFileInParentsP isSandboxConfig dir + return $ case find (not . null . snd) $ dss of + Just (sbDir, _:_) -> Just sbDir + _ -> Nothing + + where + isSandboxConfig = (=="cabal.sandbox.config") + + +appendDir :: DirPath -> [FileName] -> [FilePath] +appendDir d fs = (d ) `map` fs zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)] zipMapM f as = mapM (\a -> liftM (a,) $ f a) as @@ -91,10 +126,10 @@ parents dir' = -- | Get path to sandbox config file getSandboxDb :: FilePath -- ^ Path to the cabal package root directory -- (containing the @cabal.sandbox.config@ file) - -> IO (Maybe FilePath) + -> IO (Maybe GhcPkgDb) getSandboxDb d = do mConf <- traverse readFile =<< U.mightExist (d "cabal.sandbox.config") - return $ fixPkgDbVer <$> (extractSandboxDbDir =<< mConf) + return $ PackageDb . fixPkgDbVer <$> (extractSandboxDbDir =<< mConf) where fixPkgDbVer dir = From 36ed081d549b4a9a4e39938776c7287159c636c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 7 Feb 2015 16:41:15 +0100 Subject: [PATCH 010/207] Bring test suite up to date --- test/BrowseSpec.hs | 2 +- test/CabalApiSpec.hs | 35 ++++++++++++++++++++++++++++++----- test/CheckSpec.hs | 14 +++++++------- test/CradleSpec.hs | 34 ++++++++++++++++++++++++---------- test/Main.hs | 2 +- test/PathsAndFilesSpec.hs | 25 ++++++++++++++----------- test/TestUtils.hs | 25 ++++++++++++++++++++++--- 7 files changed, 99 insertions(+), 38 deletions(-) diff --git a/test/BrowseSpec.hs b/test/BrowseSpec.hs index b56f286..aa4942a 100644 --- a/test/BrowseSpec.hs +++ b/test/BrowseSpec.hs @@ -28,5 +28,5 @@ spec = do describe "`browse' in a project directory" $ do it "lists symbols defined in a a local module (e.g. `Baz.baz)" $ do withDirectory_ "test/data" $ do - syms <- runID $ lines <$> browse "Baz" + syms <- runD $ lines <$> browse "Baz" syms `shouldContain` ["baz"] diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index a5cba69..591c78b 100644 --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -40,20 +40,45 @@ spec = do ghcOptions = ghcOptions res , includeDirs = map (toRelativeDir dir) (includeDirs res) } + + let [fGlobalPkg, fNoUserPkg, fPkg, sb, _] = ghcOptions res' + + sb `shouldSatisfy` + isPkgConfDAt (cwd "test/data/.cabal-sandbox") + if ghcVersion < 706 - then ghcOptions res' `shouldContain` ["-global-package-conf", "-no-user-package-conf","-package-conf",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"] - else ghcOptions res' `shouldContain` ["-global-package-db", "-no-user-package-db","-package-db",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"] - includeDirs res' `shouldBe` ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"] + then do + fGlobalPkg `shouldBe` "-global-package-conf" + fNoUserPkg `shouldBe` "-no-user-package-conf" + fPkg `shouldBe` "-package-conf" + + else do + fGlobalPkg `shouldBe` "-global-package-db" + fNoUserPkg `shouldBe` "-no-user-package-db" + fPkg `shouldBe` "-package-db" + + includeDirs res' `shouldBe` [ + "test/data", + "test/data/dist/build", + "test/data/dist/build/autogen", + "test/data/subdir1/subdir2", + "test/data/test"] + (pkgName `map` depPackages res') `shouldContain` ["Cabal"] describe "cabalSourceDirs" $ do it "extracts all hs-source-dirs" $ do crdl <- findCradle' "test/data/check-test-subdir" - dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/check-test-subdir/check-test-subdir.cabal") + let cabalFile = "test/data/check-test-subdir/check-test-subdir.cabal" + dirs <- cabalSourceDirs . cabalAllBuildInfo + <$> runD (parseCabalFile crdl cabalFile) + dirs `shouldBe` ["src", "test"] + it "extracts all hs-source-dirs including \".\"" $ do crdl <- findCradle' "test/data/" - dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal") + dirs <- cabalSourceDirs . cabalAllBuildInfo + <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal") dirs `shouldBe` [".", "test"] describe "cabalAllBuildInfo" $ do diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index 35e5992..cccaaeb 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -14,38 +14,38 @@ spec = do describe "checkSyntax" $ do it "works even if an executable depends on the library defined in the same cabal file" $ do withDirectory_ "test/data/ghc-mod-check" $ do - res <- runID $ checkSyntax ["main.hs"] + res <- runD $ checkSyntax ["main.hs"] res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n" it "works even if a module imports another module from a different directory" $ do withDirectory_ "test/data/check-test-subdir" $ do - res <- runID $ checkSyntax ["test/Bar/Baz.hs"] + res <- runD $ checkSyntax ["test/Bar/Baz.hs"] res `shouldSatisfy` (("test" "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`) it "detects cyclic imports" $ do withDirectory_ "test/data" $ do - res <- runID $ checkSyntax ["Mutual1.hs"] + res <- runD $ checkSyntax ["Mutual1.hs"] res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`) it "works with modules using QuasiQuotes" $ do withDirectory_ "test/data" $ do - res <- runID $ checkSyntax ["Baz.hs"] + res <- runD $ checkSyntax ["Baz.hs"] res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`) #if __GLASGOW_HASKELL__ >= 708 it "works with modules using PatternSynonyms" $ do withDirectory_ "test/data/pattern-synonyms" $ do - res <- runID $ checkSyntax ["B.hs"] + res <- runD $ checkSyntax ["B.hs"] res `shouldSatisfy` ("B.hs:6:9:Warning:" `isPrefixOf`) #endif it "works with foreign exports" $ do withDirectory_ "test/data" $ do - res <- runID $ checkSyntax ["ForeignExport.hs"] + res <- runD $ checkSyntax ["ForeignExport.hs"] res `shouldBe` "" context "when no errors are found" $ do it "doesn't output an empty line" $ do withDirectory_ "test/data/ghc-mod-check/Data" $ do - res <- runID $ checkSyntax ["Foo.hs"] + res <- runD $ checkSyntax ["Foo.hs"] res `shouldBe` "" diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index 60ae5ac..f0fe38a 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -9,6 +9,7 @@ import System.FilePath ((), pathSeparator) import Test.Hspec import Dir +import TestUtils spec :: Spec spec = do @@ -26,24 +27,37 @@ spec = do cwd <- getCurrentDirectory withDirectory "test/data/subdir1/subdir2" $ \dir -> do res <- relativeCradle dir <$> findCradle - cradleCurrentDir res `shouldBe` "test" "data" "subdir1" "subdir2" + + cradleCurrentDir res `shouldBe` + "test" "data" "subdir1" "subdir2" + cradleRootDir res `shouldBe` "test" "data" - cradleCabalFile res `shouldBe` Just ("test" "data" "cabalapi.cabal") - cradlePkgDbStack res `shouldBe` [GlobalDb, PackageDb (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")] + + cradleCabalFile res `shouldBe` + Just ("test" "data" "cabalapi.cabal") + + let [GlobalDb, sb] = cradlePkgDbStack res + sb `shouldSatisfy` isPkgDbAt (cwd "test/data/.cabal-sandbox") it "works even if a sandbox config file is broken" $ do withDirectory "test/data/broken-sandbox" $ \dir -> do res <- relativeCradle dir <$> findCradle - cradleCurrentDir res `shouldBe` "test" "data" "broken-sandbox" - cradleRootDir res `shouldBe` "test" "data" "broken-sandbox" - cradleCabalFile res `shouldBe` Just ("test" "data" "broken-sandbox" "dummy.cabal") + cradleCurrentDir res `shouldBe` + "test" "data" "broken-sandbox" + + cradleRootDir res `shouldBe` + "test" "data" "broken-sandbox" + + cradleCabalFile res `shouldBe` + Just ("test" "data" "broken-sandbox" "dummy.cabal") + cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb] relativeCradle :: FilePath -> Cradle -> Cradle -relativeCradle dir cradle = cradle { - cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir cradle - , cradleRootDir = toRelativeDir dir $ cradleRootDir cradle - , cradleCabalFile = toRelativeDir dir <$> cradleCabalFile cradle +relativeCradle dir crdl = crdl { + cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir crdl + , cradleRootDir = toRelativeDir dir $ cradleRootDir crdl + , cradleCabalFile = toRelativeDir dir <$> cradleCabalFile crdl } -- Work around GHC 7.2.2 where `canonicalizePath "/"` returns "/.". diff --git a/test/Main.hs b/test/Main.hs index c831354..17b3920 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -24,7 +24,7 @@ main = do genGhcPkgCache dir = system $ "ghc-pkg recache --force -f" ++ dir genSandboxCfg `mapM_` sandboxes genGhcPkgCache `mapM_` pkgDirs - void $ system "find test -name setup-config -name ghc-mod.cache -exec rm {} \\;" + void $ system "find test \\( -name setup-config -o -name ghc-mod.cache \\) -exec rm {} \\;" void $ system "cabal --version" putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal void $ system "ghc --version" diff --git a/test/PathsAndFilesSpec.hs b/test/PathsAndFilesSpec.hs index c1b5143..cdf1029 100644 --- a/test/PathsAndFilesSpec.hs +++ b/test/PathsAndFilesSpec.hs @@ -3,14 +3,13 @@ module PathsAndFilesSpec where import Language.Haskell.GhcMod.PathsAndFiles #if __GLASGOW_HASKELL__ <= 706 -import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.GhcPkg #endif import System.Directory -import System.Environment -import System.FilePath (()) +import System.FilePath import Test.Hspec +import TestUtils spec :: Spec spec = do @@ -18,25 +17,29 @@ spec = do -- ghc < 7.8 #if __GLASGOW_HASKELL__ <= 706 it "does include a sandbox with ghc < 7.8" $ do - cwd <- getCurrentDirectory - getPackageDbStack "test/data/" `shouldReturn` [GlobalDb, PackageDb $ cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"] + cwd <- getCurrentDirectory + [GlobalDb, sbPkgDb] <- getPackageDbStack "test/data/" + sbPkgDb `shouldSatisfy` isPkgDbAt (cwd "test/data/.cabal-sandbox") #endif it "can parse a config file and extract the sandbox package-db" $ do cwd <- getCurrentDirectory - pkgDb <- getSandboxDb "test/data/" - pkgDb `shouldBe` Just (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") + Just db <- getSandboxDb "test/data/" + db `shouldSatisfy` isPkgDbAt (cwd "test/data/.cabal-sandbox") it "returns Nothing if the sandbox config file is broken" $ do getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing - describe "getCabalFiles" $ do - it "doesn't think $HOME/.cabal is a cabal file" $ do - (getCabalFiles =<< getEnv "HOME") `shouldReturn` [] - describe "findCabalFile" $ do it "works" $ do findCabalFile "test/data" `shouldReturn` Just "test/data/cabalapi.cabal" it "finds cabal files in parent directories" $ do findCabalFile "test/data/subdir1/subdir2" `shouldReturn` Just "test/data/cabalapi.cabal" + + describe "findCabalSandboxDir" $ do + it "works" $ do + findCabalSandboxDir "test/data" `shouldReturn` Just "test/data" + + it "finds sandboxes in parent directories" $ do + findCabalSandboxDir "test/data/subdir1/subdir2" `shouldReturn` Just "test/data" diff --git a/test/TestUtils.hs b/test/TestUtils.hs index a543f37..180cec9 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -3,10 +3,12 @@ module TestUtils ( , runD , runD' , runI - , runID +-- , runID , runIsolatedGhcMod , isolateCradle , shouldReturnError + , isPkgDbAt + , isPkgConfDAt , module Language.Haskell.GhcMod.Monad , module Language.Haskell.GhcMod.Types ) where @@ -14,6 +16,8 @@ module TestUtils ( import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types +import Data.List.Split +import System.FilePath import Test.Hspec isolateCradle :: IOish m => GhcModT m a -> GhcModT m a @@ -34,8 +38,8 @@ runIsolatedGhcMod opt action = do extract $ runGhcModT opt $ isolateCradle action -- | Run GhcMod in isolated cradle with default options -runID :: GhcModT IO a -> IO a -runID = runIsolatedGhcMod defaultOptions +--runID :: GhcModT IO a -> IO a +--runID = runIsolatedGhcMod defaultOptions -- | Run GhcMod in isolated cradle runI :: Options -> GhcModT IO a -> IO a @@ -61,3 +65,18 @@ shouldReturnError action = do where isLeft (Left _) = True isLeft _ = False + +isPkgConfD :: FilePath -> Bool +isPkgConfD d = let + (_dir, pkgconfd) = splitFileName d + in case splitOn "-" pkgconfd of + [_arch, _platform, _compiler, _compver, "packages.conf.d"] -> True + _ -> False + +isPkgConfDAt :: FilePath -> FilePath -> Bool +isPkgConfDAt d d' | d == takeDirectory d' && isPkgConfD d' = True +isPkgConfDAt _ _ = False + +isPkgDbAt :: FilePath -> GhcPkgDb -> Bool +isPkgDbAt d (PackageDb dir) = isPkgConfDAt d dir +isPkgDbAt _ _ = False From 471a3ec358d1ce8cb5cae445496adf11b6ad09f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 7 Feb 2015 23:05:04 +0100 Subject: [PATCH 011/207] Fix ghc-7.4 --- SetupCompat.hs | 9 +++++++++ ghc-mod.cabal | 3 +++ 2 files changed, 12 insertions(+) diff --git a/SetupCompat.hs b/SetupCompat.hs index 1082532..b39475d 100644 --- a/SetupCompat.hs +++ b/SetupCompat.hs @@ -102,3 +102,12 @@ setComponentsConfigs setComponentsConfigs lbi cs = lbi { componentsConfigs = cs } #endif + + +#if __GLASGOW_HASKELL__ <= 704 + +componentBuildInfo :: Component -> BuildInfo +componentBuildInfo = + foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo + +#endif diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 9b0eead..65ce6ff 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -26,6 +26,7 @@ Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-check.el ghc-process.el ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el ghc-pkg.el ghc-rewrite.el Extra-Source-Files: ChangeLog + SetupCompat.hs test/data/*.cabal test/data/*.hs test/data/cabal.sandbox.config.in @@ -218,6 +219,8 @@ Test-Suite spec TestUtils Build-Depends: hspec + if impl(ghc == 7.4.*) + Build-Depends: executable-path X-Build-Depends-Like: CLibName From 405b81472658964e988a98bd088b7a523bf178b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 7 Feb 2015 23:43:56 +0100 Subject: [PATCH 012/207] Add cabal-helper for decoding Cabal-1.22 setup-configs .. without having to worry about Cabal version conflicts --- ghc-mod.cabal | 15 +++++++++++++++ src/GHCModCabal.hs | 28 ++++++++++++++++++++++++++++ 2 files changed, 43 insertions(+) create mode 100644 src/GHCModCabal.hs diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 65ce6ff..1fe41be 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -186,6 +186,21 @@ Executable ghc-modi , ghc , ghc-mod +Executable cabal-helper + Default-Language: Haskell2010 + Main-Is: GHCModCabal.hs + GHC-Options: -Wall + HS-Source-Dirs: src + X-Install-Target: $libexecdir + Build-Depends: base >= 4.0 && < 5 + , bytestring + , binary + , directory + if flag(cabal-122) + Build-Depends: Cabal >= 1.22 + else + Buildable: False + Test-Suite doctest Type: exitcode-stdio-1.0 Default-Language: Haskell2010 diff --git a/src/GHCModCabal.hs b/src/GHCModCabal.hs new file mode 100644 index 0000000..5aec6d9 --- /dev/null +++ b/src/GHCModCabal.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE BangPatterns #-} +module Main where + +import Control.Applicative + +import Distribution.Simple.Utils (cabalVersion) +import Distribution.Simple.Configure +import Distribution.Text ( display ) +import System.Environment +import System.Directory + +main :: IO () +main = do + args <- getArgs + case args of + "version":[] -> do + putStrLn $ "using version " ++ display cabalVersion ++ " of the Cabal library" + "print-setup-config":args' -> do + mfile <- findFile ["dist"] "setup-config" + + let file = case mfile of + Just f -> f + Nothing -> let !(f:[]) = args' in f + + putStrLn =<< show <$> getConfigStateFile file + + cmd:_ -> error $ "Unknown command: " ++ cmd + [] -> error "No command given" From 1c5a1c8b3ef9dd158cda528f68a6f68ccc219888 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 7 Feb 2015 23:48:33 +0100 Subject: [PATCH 013/207] Add util function for finding libexec binaries --- Language/Haskell/GhcMod/Utils.hs | 32 +++++++++++++++++++++++++++----- 1 file changed, 27 insertions(+), 5 deletions(-) diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 5182089..1f1f63d 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -2,6 +2,7 @@ module Language.Haskell.GhcMod.Utils where import Control.Arrow +import Control.Applicative ((<$>)) import Data.Char import Language.Haskell.GhcMod.Error import MonadUtils (MonadIO, liftIO) @@ -9,12 +10,16 @@ import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist import System.Exit (ExitCode(..)) import System.Process (readProcessWithExitCode) import System.Directory (getTemporaryDirectory) -import System.FilePath (splitDrive, pathSeparators) +import System.FilePath (splitDrive, pathSeparators, ()) import System.IO.Temp (createTempDirectory) #ifndef SPEC -import Control.Applicative ((<$>)) +import Paths_ghc_mod (getLibexecDir) import System.Environment -import System.FilePath ((), takeDirectory) +import System.FilePath (takeDirectory) +#else +-- When compiling test suite +import Data.IORef +import System.IO.Unsafe #endif -- dropWhileEnd is not provided prior to base 4.5.0.0. @@ -33,7 +38,7 @@ extractParens str = extractParens' str 0 | s `elem` "}])" = s : extractParens' ss (level-1) | otherwise = s : extractParens' ss level -readProcess' :: (MonadIO m, MonadError GhcModError m) +readProcess' :: (MonadIO m, GmError m) => String -> [String] -> m String @@ -90,5 +95,22 @@ ghcModExecutable = do getExecutablePath' = return "" # endif #else -ghcModExecutable = return "dist/build/ghc-mod/ghc-mod" +ghcModExecutable = fmap ( "dist/build/ghc-mod/ghc-mod") getCurrentDirectory #endif + +#ifdef SPEC +-- Ugly workaround :'( but I can't think of any other way of doing this +-- the test suite changes the cwd often so I can't use relative paths :/ +specRootDir :: IORef FilePath +specRootDir = unsafePerformIO $ newIORef undefined +{-# NOINLINE specRootDir #-} +#endif + +findLibexecExe :: String -> IO FilePath +#ifndef SPEC +findLibexecExe "cabal-helper" = (fmap ( "cabal-helper")) getLibexecDir +#else +findLibexecExe "cabal-helper" = + ( "dist/build/cabal-helper/cabal-helper") <$> (readIORef specRootDir) +#endif +findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe From 844bdea3dbe998fb6297b41ab75abb710cac1f4e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 7 Feb 2015 23:52:26 +0100 Subject: [PATCH 014/207] Move `symbolCache` to PathsAndFiles --- Language/Haskell/GhcMod/Find.hs | 13 +------------ Language/Haskell/GhcMod/PathsAndFiles.hs | 6 ++++++ 2 files changed, 7 insertions(+), 12 deletions(-) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index a848c3e..09c1c4f 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -61,17 +61,6 @@ isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db ---------------------------------------------------------------- --- | When introducing incompatible changes to the 'symbolCache' file format --- increment this version number. -symbolCacheVersion :: Integer -symbolCacheVersion = 0 - --- | Filename of the symbol table cache file. -symbolCache :: String -symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache" - ----------------------------------------------------------------- - -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] -- which will be concatenated. 'loadSymbolDb' is called internally. findSymbol :: IOish m => Symbol -> GhcModT m String @@ -114,7 +103,7 @@ loadSymbolDb = do dumpSymbol :: IOish m => FilePath -> GhcModT m String dumpSymbol dir = do - let cache = dir symbolCache + let cache = dir symbolCacheFile pkgdb = dir packageCache create <- liftIO $ cache `isOlderThan` pkgdb diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 4bef50d..eac0775 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -164,3 +164,9 @@ ghcSandboxPkgDbDir = packageCache :: String packageCache = "package.cache" +-- | Filename of the symbol table cache file. +symbolCache :: Cradle -> FilePath +symbolCache crdl = cradleTempDir crdl symbolCacheFile + +symbolCacheFile :: String +symbolCacheFile = "ghc-mod-0.symbol-cache" From ef96b926c7b60e2df5e7cd384a1da25507666fa1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 7 Feb 2015 23:55:57 +0100 Subject: [PATCH 015/207] Use cabal-helper to support Cabal >= 1.22 with any version of ghc --- Language/Haskell/GhcMod/CabalApi.hs | 16 +- Language/Haskell/GhcMod/CabalConfig.hs | 29 +- .../Haskell/GhcMod/CabalConfig/Cabal22.hs | 107 +++++++ .../Haskell/GhcMod/CabalConfig/Extract.hs | 223 +++++++++++++ Language/Haskell/GhcMod/CabalConfig/Ghc710.hs | 10 +- .../Haskell/GhcMod/CabalConfig/PreGhc710.hs | 154 --------- Language/Haskell/GhcMod/Debug.hs | 8 +- Language/Haskell/GhcMod/Error.hs | 60 ++++ Language/Haskell/GhcMod/Logging.hs | 21 ++ Language/Haskell/GhcMod/Monad.hs | 297 ++---------------- Language/Haskell/GhcMod/Monad/Types.hs | 288 +++++++++++++++++ Language/Haskell/GhcMod/PathsAndFiles.hs | 10 +- Language/Haskell/GhcMod/World.hs | 31 +- Setup.hs | 2 +- ghc-mod.cabal | 14 +- 15 files changed, 789 insertions(+), 481 deletions(-) create mode 100644 Language/Haskell/GhcMod/CabalConfig/Cabal22.hs create mode 100644 Language/Haskell/GhcMod/CabalConfig/Extract.hs delete mode 100644 Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs create mode 100644 Language/Haskell/GhcMod/Logging.hs create mode 100644 Language/Haskell/GhcMod/Monad/Types.hs diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index 701e5b4..063a1fa 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -13,6 +13,7 @@ import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, mkGHCCompilerId) import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Logging import MonadUtils (liftIO) import Control.Applicative ((<$>)) @@ -36,14 +37,15 @@ import System.FilePath (()) ---------------------------------------------------------------- -- | Getting necessary 'CompilerOptions' from three information sources. -getCompilerOptions :: (IOish m, MonadError GhcModError m) +getCompilerOptions :: (IOish m, GmError m, GmLog m) => [GHCOption] -> Cradle + -> CabalConfig -> PackageDescription -> m CompilerOptions -getCompilerOptions ghcopts cradle pkgDesc = do +getCompilerOptions ghcopts cradle config pkgDesc = do gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos - depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc) + let depPkgs = cabalConfigDependencies config (C.packageId pkgDesc) return $ CompilerOptions gopts idirs depPkgs where wdir = cradleCurrentDir cradle @@ -67,14 +69,14 @@ includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir]) ---------------------------------------------------------------- -- | Parse a cabal file and return a 'PackageDescription'. -parseCabalFile :: (IOish m, MonadError GhcModError m) - => Cradle +parseCabalFile :: (IOish m, GmError m, GmLog m) + => CabalConfig -> FilePath -> m PackageDescription -parseCabalFile cradle file = do +parseCabalFile config file = do cid <- mkGHCCompilerId <$> liftIO getGHCVersion epgd <- liftIO $ readPackageDescription silent file - flags <- cabalConfigFlags cradle + flags <- cabalConfigFlags config case toPkgDesc cid flags epgd of Left deps -> fail $ show deps ++ " are not installed" Right (pd,_) -> if nullPkg pd diff --git a/Language/Haskell/GhcMod/CabalConfig.hs b/Language/Haskell/GhcMod/CabalConfig.hs index 79f48d7..2d9d9da 100644 --- a/Language/Haskell/GhcMod/CabalConfig.hs +++ b/Language/Haskell/GhcMod/CabalConfig.hs @@ -4,39 +4,32 @@ -- 'LocalBuildInfo' (@dist/setup-config@) for different version combinations of -- Cabal and GHC. module Language.Haskell.GhcMod.CabalConfig ( - cabalConfigDependencies + CabalConfig + , cabalGetConfig + , cabalConfigDependencies , cabalConfigFlags ) where -import Control.Applicative import Distribution.Package (PackageIdentifier) import Distribution.PackageDescription (FlagAssignment) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Error -#if __GLASGOW_HASKELL__ >= 710 -import Language.Haskell.GhcMod.CabalConfig.Ghc710 -#else -import Language.Haskell.GhcMod.CabalConfig.PreGhc710 -#endif +import Language.Haskell.GhcMod.CabalConfig.Extract +cabalGetConfig :: (IOish m, GmError m) => Cradle -> m CabalConfig +cabalGetConfig = getConfig -- | Get list of 'Package's needed by all components of the current package -cabalConfigDependencies :: (IOish m, MonadError GhcModError m) - => Cradle - -> PackageIdentifier - -> m [Package] -cabalConfigDependencies cradle thisPkg = - configDependencies thisPkg <$> getConfig cradle +cabalConfigDependencies :: CabalConfig -> PackageIdentifier -> [Package] +cabalConfigDependencies config thisPkg = + configDependencies thisPkg config -- | Get the flag assignment from the local build info of the given cradle -cabalConfigFlags :: (IOish m, MonadError GhcModError m) - => Cradle - -> m FlagAssignment -cabalConfigFlags cradle = do - config <- getConfig cradle +cabalConfigFlags :: (IOish m, GmError m) => CabalConfig -> m FlagAssignment +cabalConfigFlags config = do case configFlags config of Right x -> return x Left msg -> throwError (GMECabalFlags (GMEString msg)) diff --git a/Language/Haskell/GhcMod/CabalConfig/Cabal22.hs b/Language/Haskell/GhcMod/CabalConfig/Cabal22.hs new file mode 100644 index 0000000..da6ef88 --- /dev/null +++ b/Language/Haskell/GhcMod/CabalConfig/Cabal22.hs @@ -0,0 +1,107 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +-- Copyright : Isaac Jones 2003-2004 +-- Copyright : (c) The University of Glasgow 2004 +-- Copyright : Duncan Coutts 2008 +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +-- | ComponentLocalBuildInfo for Cabal >= 1.22 +module Language.Haskell.GhcMod.CabalConfig.Cabal22 ( + ComponentLocalBuildInfo + , PackageIdentifier(..) + , PackageName(..) + , componentPackageDeps + , componentLibraries + ) where + +import Distribution.Package (InstalledPackageId) +import Data.Version (Version) +import Data.Map (Map) + +data LibraryName = LibraryName String + deriving (Read, Show) + +newtype PackageName = PackageName { unPackageName :: String } + deriving (Read, Show, Ord, Eq) + +data PackageIdentifier + = PackageIdentifier { + pkgName :: PackageName, + pkgVersion :: Version + } + deriving (Read, Show) + +type PackageId = PackageIdentifier + +newtype ModuleName = ModuleName [String] + deriving (Read, Show) + +data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)] + deriving (Read, Show) + +data OriginalModule + = OriginalModule { + originalPackageId :: InstalledPackageId, + originalModuleName :: ModuleName + } + deriving (Read, Show) + +data ExposedModule + = ExposedModule { + exposedName :: ModuleName, + exposedReexport :: Maybe OriginalModule, + exposedSignature :: Maybe OriginalModule -- This field is unused for now. + } + deriving (Read, Show) + +data ComponentLocalBuildInfo + = LibComponentLocalBuildInfo { + -- | Resolved internal and external package dependencies for this component. + -- The 'BuildInfo' specifies a set of build dependencies that must be + -- satisfied in terms of version ranges. This field fixes those dependencies + -- to the specific versions available on this machine for this compiler. + componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentExposedModules :: [ExposedModule], + componentPackageRenaming :: Map PackageName ModuleRenaming, + componentLibraries :: [LibraryName] + } + | ExeComponentLocalBuildInfo { + componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentPackageRenaming :: Map PackageName ModuleRenaming + } + | TestComponentLocalBuildInfo { + componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentPackageRenaming :: Map PackageName ModuleRenaming + } + | BenchComponentLocalBuildInfo { + componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentPackageRenaming :: Map PackageName ModuleRenaming + } + deriving (Read, Show) diff --git a/Language/Haskell/GhcMod/CabalConfig/Extract.hs b/Language/Haskell/GhcMod/CabalConfig/Extract.hs new file mode 100644 index 0000000..ea0c3bd --- /dev/null +++ b/Language/Haskell/GhcMod/CabalConfig/Extract.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE RecordWildCards, CPP, OverloadedStrings #-} + +-- | This module facilitates extracting information from Cabal's on-disk +-- 'LocalBuildInfo' (@dist/setup-config@). +module Language.Haskell.GhcMod.CabalConfig.Extract ( + CabalConfig + , configDependencies + , configFlags + , getConfig + ) where + +import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.Read +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Utils +import Language.Haskell.GhcMod.World + +import qualified Language.Haskell.GhcMod.CabalConfig.Cabal16 as C16 +import qualified Language.Haskell.GhcMod.CabalConfig.Cabal18 as C18 +import qualified Language.Haskell.GhcMod.CabalConfig.Cabal22 as C22 + +#ifndef MIN_VERSION_mtl +#define MIN_VERSION_mtl(x,y,z) 1 +#endif + +import Control.Applicative ((<$>)) +import Control.Monad (void, mplus, when) +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except () +#else +import Control.Monad.Error () +#endif +import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) +import Data.Version +import Distribution.Package (InstalledPackageId(..) + , PackageIdentifier(..) + , PackageName(..)) +import Distribution.PackageDescription (FlagAssignment) +import Distribution.Simple.LocalBuildInfo (ComponentName) +import MonadUtils (liftIO) +import Text.ParserCombinators.ReadP + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +---------------------------------------------------------------- + +-- | 'Show'ed cabal 'LocalBuildInfo' string +newtype CabalConfig = CabalConfig { unCabalConfig :: String } + +-- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't +-- exist run @cabal configure@ i.e. configure with default options like @cabal +-- build@ would do. +getConfig :: (IOish m, GmError m) => Cradle -> m CabalConfig +getConfig crdl = do + liftIO (getCurrentWorld crdl) >>= \world -> + when (isSetupConfigOutOfDate world) configure + + cfg <- liftIO (BS.readFile file) `tryFix` \_ -> + configure `modifyError'` GMECabalConfigure + + liftIO (getCurrentWorld crdl) >>= \world -> + decodeConfig crdl world file cfg + where + file = setupConfigFile crdl + prjDir = cradleRootDir crdl + + configure :: (IOish m, GmError m) => m () + configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] + +decodeConfig :: (IOish m, GmError m) + => Cradle -> World -> FilePath -> ByteString -> m CabalConfig +decodeConfig _crdl _world file bs = CabalConfig <$> gen + +-- if cacheOutdated world +-- then +-- gmLog $ "Regenerating pretty setup-config cache: " ++ prettyConfigCache +-- liftIO $ writeFile prettyConfigCache cfg +-- else CabalConfig <$> liftIO (readFile prettyConfigCache) + + where + -- cacheOutdated World {..} = + -- case (worldCabalConfig, worldPrettyCabalConfigCache) of + -- (Nothing, _) -> error "decodeConfig: setup-config does not exist." + -- (Just _, Nothing) -> True + -- (Just s, Just p) -> s > p + + gen = case BS8.lines bs of + header:_ -> do + ((_,cabalVer), _) <- parseHeader header + if cabalVer >= (Version [1,22] []) + then prettyPrintBinaryConfig file + else return $ bsToStr bs + [] -> throwError $ GMECabalStateFile GMConfigStateFileNoHeader + +prettyPrintBinaryConfig :: (IOish m, GmError m) + => String -> m String +prettyPrintBinaryConfig file = do + exe <- liftIO $ findLibexecExe "ghc-mod-cabal" + slbi <- readProcess' exe ["print-setup-config", file] + return slbi + +parseHeader :: GmError m + => ByteString -> m ((ByteString, Version), (ByteString, Version)) +parseHeader header = case BS8.words header of + ["Saved", "package", "config", "for", _pkgId , "written", "by", cabalId, "using", compId] -> modifyError (\_ -> GMECabalStateFile GMConfigStateFileBadHeader) $ do + cabalId' <- parsePkgId cabalId + compId' <- parsePkgId compId + return (cabalId', compId') + + _ -> throwError $ GMECabalStateFile GMConfigStateFileNoHeader + +parsePkgId :: (Error e, MonadError e m) => ByteString -> m (ByteString, Version) +parsePkgId bs = + case BS8.split '-' bs of + [pkg, vers] -> return (pkg, parseVer vers) + _ -> throwError noMsg + where + parseVer vers = + let (ver,""):[] = + filter ((=="") . snd) $ readP_to_S parseVersion (bsToStr vers) + in ver + +bsToStr :: ByteString -> String +bsToStr = T.unpack . T.decodeUtf8 + +-- strToBs :: String -> ByteString +-- strToBs = T.encodeUtf8 . T.pack + +-- | Extract list of depencenies for all components from 'CabalConfig' +configDependencies :: PackageIdentifier -> CabalConfig -> [Package] +configDependencies thisPkg config = map fromInstalledPackageId deps + where + deps :: [InstalledPackageId] + deps = case deps16 `mplus` deps18 `mplus` deps22 of + Right ps -> ps + Left msg -> error msg + + -- True if this dependency is an internal one (depends on the library + -- defined in the same package). + internal pkgid = pkgid == thisPkg + + -- Cabal >= 1.22 + deps22 :: Either String [InstalledPackageId] + deps22 = + map fst + <$> filterInternal22 + <$> (readEither =<< extractField (unCabalConfig config) "componentsConfigs") + + filterInternal22 + :: [(ComponentName, C22.ComponentLocalBuildInfo, [ComponentName])] + -> [(InstalledPackageId, C22.PackageIdentifier)] + + filterInternal22 ccfg = [ (ipkgid, pkgid) + | (_,clbi,_) <- ccfg + , (ipkgid, pkgid) <- C22.componentPackageDeps clbi + , not (internal . packageIdentifierFrom22 $ pkgid) ] + + packageIdentifierFrom22 :: C22.PackageIdentifier -> PackageIdentifier + packageIdentifierFrom22 (C22.PackageIdentifier (C22.PackageName myName) myVersion) = + PackageIdentifier (PackageName myName) myVersion + + -- Cabal >= 1.18 && < 1.20 + deps18 :: Either String [InstalledPackageId] + deps18 = + map fst + <$> filterInternal + <$> (readEither =<< extractField (unCabalConfig config) "componentsConfigs") + + filterInternal + :: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])] + -> [(InstalledPackageId, PackageIdentifier)] + + filterInternal ccfg = [ (ipkgid, pkgid) + | (_,clbi,_) <- ccfg + , (ipkgid, pkgid) <- C18.componentPackageDeps clbi + , not (internal pkgid) ] + + -- Cabal 1.16 and below + deps16 :: Either String [InstalledPackageId] + deps16 = map fst <$> filter (not . internal . snd) . nub <$> do + cbi <- concat <$> sequence [ extract "executableConfigs" + , extract "testSuiteConfigs" + , extract "benchmarkConfigs" ] + :: Either String [(String, C16.ComponentLocalBuildInfo)] + + return $ maybe [] C16.componentPackageDeps libraryConfig + ++ concatMap (C16.componentPackageDeps . snd) cbi + where + libraryConfig :: Maybe C16.ComponentLocalBuildInfo + libraryConfig = do + field <- find ("libraryConfig" `isPrefixOf`) (tails $ unCabalConfig config) + clbi <- stripPrefix " = " field + if "Nothing" `isPrefixOf` clbi + then Nothing + else case readMaybe =<< stripPrefix "Just " clbi of + Just x -> x + Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi) + + extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)] + extract field = readConfigs field <$> extractField (unCabalConfig config) field + + readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)] + readConfigs f s = case readEither s of + Right x -> x + Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")" + +-- | Extract the cabal flags from the 'CabalConfig' +configFlags :: CabalConfig -> Either String FlagAssignment +configFlags (CabalConfig config) = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags" + +-- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable +-- error message with lots of context on failure. +extractField :: String -> String -> Either String String +extractField content field = + case extractParens <$> find (field `isPrefixOf`) (tails content) of + Just f -> Right f + Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` content) diff --git a/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs b/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs index 2f0b41c..76e5308 100644 --- a/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs +++ b/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs @@ -17,6 +17,7 @@ import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World @@ -24,19 +25,18 @@ import Language.Haskell.GhcMod.World -- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't -- exist run @cabal configure@ i.e. configure with default options like @cabal -- build@ would do. -getConfig :: (IOish m, MonadError GhcModError m) +getConfig :: (IOish m, GmError m) => Cradle -> m LocalBuildInfo -getConfig cradle = do - outOfDate <- liftIO $ isSetupConfigOutOfDate cradle - when outOfDate configure +getConfig cradle = liftIO (getCurrentWorld cradle) >>= \world -> do + when (isSetupConfigOutOfDate world) configure liftIO (getConfigStateFile file) `tryFix` \_ -> configure `modifyError'` GMECabalConfigure where file = setupConfigFile cradle prjDir = cradleRootDir cradle - configure :: (IOish m, MonadError GhcModError m) => m () + configure :: (IOish m, GmError m) => m () configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] configDependencies :: a -> LocalBuildInfo -> [Package] diff --git a/Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs b/Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs deleted file mode 100644 index f243487..0000000 --- a/Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE RecordWildCards, CPP #-} - --- | This module facilitates extracting information from Cabal's on-disk --- 'LocalBuildInfo' (@dist/setup-config@). -module Language.Haskell.GhcMod.CabalConfig.PreGhc710 ( - configDependencies - , configFlags - , getConfig - ) where - -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.Read -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.World - -import qualified Language.Haskell.GhcMod.CabalConfig.Cabal16 as C16 -import qualified Language.Haskell.GhcMod.CabalConfig.Cabal18 as C18 -import qualified Language.Haskell.GhcMod.CabalConfig.Cabal21 as C21 - -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(x,y,z) 1 -#endif - -import Control.Applicative ((<$>)) -import Control.Monad (void, mplus, when) -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except () -#else -import Control.Monad.Error () -#endif -import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) -import Distribution.Package (InstalledPackageId(..) - , PackageIdentifier(..) - , PackageName(..)) -import Distribution.PackageDescription (FlagAssignment) -import Distribution.Simple.LocalBuildInfo (ComponentName) -import MonadUtils (liftIO) - ----------------------------------------------------------------- - --- | 'Show'ed cabal 'LocalBuildInfo' string -type CabalConfig = String - --- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't --- exist run @cabal configure@ i.e. configure with default options like @cabal --- build@ would do. -getConfig :: (IOish m, MonadError GhcModError m) - => Cradle - -> m CabalConfig -getConfig cradle = do - outOfDate <- liftIO $ isSetupConfigOutOfDate cradle - when outOfDate configure - liftIO (readFile file) `tryFix` \_ -> - configure `modifyError'` GMECabalConfigure - where - file = setupConfigFile cradle - prjDir = cradleRootDir cradle - - configure :: (IOish m, MonadError GhcModError m) => m () - configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] - - --- | Extract list of depencenies for all components from 'CabalConfig' -configDependencies :: PackageIdentifier -> CabalConfig -> [Package] -configDependencies thisPkg config = map fromInstalledPackageId deps - where - deps :: [InstalledPackageId] - deps = case deps21 `mplus` deps18 `mplus` deps16 of - Right ps -> ps - Left msg -> error msg - - -- True if this dependency is an internal one (depends on the library - -- defined in the same package). - internal pkgid = pkgid == thisPkg - - -- Cabal >= 1.21 - deps21 :: Either String [InstalledPackageId] - deps21 = - map fst - <$> filterInternal21 - <$> (readEither =<< extractField config "componentsConfigs") - - filterInternal21 - :: [(ComponentName, C21.ComponentLocalBuildInfo, [ComponentName])] - -> [(InstalledPackageId, C21.PackageIdentifier)] - - filterInternal21 ccfg = [ (ipkgid, pkgid) - | (_,clbi,_) <- ccfg - , (ipkgid, pkgid) <- C21.componentPackageDeps clbi - , not (internal . packageIdentifierFrom21 $ pkgid) ] - - packageIdentifierFrom21 :: C21.PackageIdentifier -> PackageIdentifier - packageIdentifierFrom21 (C21.PackageIdentifier (C21.PackageName myName) myVersion) = - PackageIdentifier (PackageName myName) myVersion - - -- Cabal >= 1.18 && < 1.21 - deps18 :: Either String [InstalledPackageId] - deps18 = - map fst - <$> filterInternal - <$> (readEither =<< extractField config "componentsConfigs") - - filterInternal - :: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])] - -> [(InstalledPackageId, PackageIdentifier)] - - filterInternal ccfg = [ (ipkgid, pkgid) - | (_,clbi,_) <- ccfg - , (ipkgid, pkgid) <- C18.componentPackageDeps clbi - , not (internal pkgid) ] - - -- Cabal 1.16 and below - deps16 :: Either String [InstalledPackageId] - deps16 = map fst <$> filter (not . internal . snd) . nub <$> do - cbi <- concat <$> sequence [ extract "executableConfigs" - , extract "testSuiteConfigs" - , extract "benchmarkConfigs" ] - :: Either String [(String, C16.ComponentLocalBuildInfo)] - - return $ maybe [] C16.componentPackageDeps libraryConfig - ++ concatMap (C16.componentPackageDeps . snd) cbi - where - libraryConfig :: Maybe C16.ComponentLocalBuildInfo - libraryConfig = do - field <- find ("libraryConfig" `isPrefixOf`) (tails config) - clbi <- stripPrefix " = " field - if "Nothing" `isPrefixOf` clbi - then Nothing - else case readMaybe =<< stripPrefix "Just " clbi of - Just x -> x - Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi) - - extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)] - extract field = readConfigs field <$> extractField config field - - readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)] - readConfigs f s = case readEither s of - Right x -> x - Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")" - --- | Extract the cabal flags from the 'CabalConfig' -configFlags :: CabalConfig -> Either String FlagAssignment -configFlags config = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags" - --- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable --- error message with lots of context on failure. -extractField :: CabalConfig -> String -> Either String String -extractField config field = - case extractParens <$> find (field `isPrefixOf`) (tails config) of - Just f -> Right f - Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config) diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index f1382ce..f092d3e 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -6,6 +6,7 @@ import Data.Maybe (isJust, fromJust) import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.CabalConfig import Language.Haskell.GhcMod.Internal ---------------------------------------------------------------- @@ -30,9 +31,10 @@ debugInfo = cradle >>= \c -> convert' =<< do where simpleCompilerOption = options >>= \op -> return $ CompilerOptions (ghcUserOptions op) [] [] - fromCabalFile c = options >>= \opts -> do - pkgDesc <- parseCabalFile c $ fromJust $ cradleCabalFile c - getCompilerOptions (ghcUserOptions opts) c pkgDesc + fromCabalFile crdl = options >>= \opts -> do + config <- cabalGetConfig crdl + pkgDesc <- parseCabalFile config $ fromJust $ cradleCabalFile crdl + getCompilerOptions (ghcUserOptions opts) crdl config pkgDesc ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 9fa2b80..a05b1e1 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -1,6 +1,8 @@ {-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-} module Language.Haskell.GhcMod.Error ( GhcModError(..) + , GMConfigStateFileError(..) + , GmError , gmeDoc , modifyError , modifyError' @@ -15,26 +17,81 @@ import Data.Typeable import Exception import Text.PrettyPrint +type GmError m = MonadError GhcModError m + data GhcModError = GMENoMsg -- ^ Unknown error + | GMEString String -- ^ Some Error with a message. These are produced mostly by -- 'fail' calls on GhcModT. + | GMEIOException IOException -- ^ IOExceptions captured by GhcModT's MonadIO instance + | GMECabalConfigure GhcModError -- ^ Configuring a cabal project failed. + | GMECabalFlags GhcModError -- ^ Retrieval of the cabal configuration flags failed. + | GMEProcess [String] GhcModError -- ^ Launching an operating system process failed. The first -- field is the command. + | GMENoCabalFile -- ^ No cabal file found. + | GMETooManyCabalFiles [FilePath] -- ^ Too many cabal files found. + + | GMECabalStateFile GMConfigStateFileError + -- ^ Reading Cabal's state configuration file falied somehow. deriving (Eq,Show,Typeable) +data GMConfigStateFileError + = GMConfigStateFileNoHeader + | GMConfigStateFileBadHeader + | GMConfigStateFileNoParse + | GMConfigStateFileMissing +-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) + deriving (Eq, Show, Read, Typeable) + +gmCsfeDoc :: GMConfigStateFileError -> Doc +gmCsfeDoc GMConfigStateFileNoHeader = text $ + "Saved package config file header is missing. " + ++ "Try re-running the 'configure' command." + +gmCsfeDoc GMConfigStateFileBadHeader = text $ + "Saved package config file header is corrupt. " + ++ "Try re-running the 'configure' command." + +gmCsfeDoc GMConfigStateFileNoParse = text $ + "Saved package config file body is corrupt. " + ++ "Try re-running the 'configure' command." + +gmCsfeDoc GMConfigStateFileMissing = text $ + "Run the 'configure' command first." + +-- gmCsfeDoc (ConfigStateFileBadVersion oldCabal oldCompiler _) = text $ +-- "You need to re-run the 'configure' command. " +-- ++ "The version of Cabal being used has changed (was " +-- ++ display oldCabal ++ ", now " +-- ++ display currentCabalId ++ ")." +-- ++ badCompiler +-- where +-- badCompiler +-- | oldCompiler == currentCompilerId = "" +-- | otherwise = +-- " Additionally the compiler is different (was " +-- ++ display oldCompiler ++ ", now " +-- ++ display currentCompilerId +-- ++ ") which is probably the cause of the problem." + + + + + instance Exception GhcModError instance Error GhcModError where @@ -61,6 +118,9 @@ gmeDoc e = case e of GMETooManyCabalFiles cfs -> text $ "Multiple cabal files found. Possible cabal files: \"" ++ intercalate "\", \"" cfs ++"\"." + GMECabalStateFile csfe -> + gmCsfeDoc csfe + modifyError :: MonadError e m => (e -> e) -> m a -> m a modifyError f action = action `catchError` \e -> throwError $ f e diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs new file mode 100644 index 0000000..62a8412 --- /dev/null +++ b/Language/Haskell/GhcMod/Logging.hs @@ -0,0 +1,21 @@ +module Language.Haskell.GhcMod.Logging where + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types + +import Control.Monad.Journal.Class +import Control.Monad.Trans.Class +import System.IO + +import MonadUtils + +--gmSink :: IOish m => (GhcModLog -> IO ()) -> GhcModT m () +--gmSink = GhcModT . (lift . lift . sink) + +type GmLog m = MonadJournal GhcModLog m + +gmJournal :: IOish m => GhcModLog -> GhcModT m () +gmJournal = GhcModT . lift . lift . journal + +gmLog :: (MonadIO m, MonadJournal GhcModLog m) => String -> m () +gmLog str = liftIO (hPutStrLn stderr str) >> (journal $ GhcModLog [str]) diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index cbc2880..6be1b23 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -1,9 +1,4 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} -{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - +{-# LANGUAGE CPP, RecordWildCards #-} module Language.Haskell.GhcMod.Monad ( -- * Monad Types GhcModT @@ -20,41 +15,32 @@ module Language.Haskell.GhcMod.Monad ( , runGhcModT , runGhcModT' , hoistGhcModT - -- ** Accessing 'GhcModEnv' and 'GhcModState' + -- ** Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog' , gmsGet , gmsPut + , gmLog , options , cradle , getCompilerMode , setCompilerMode , withOptions , withTempSession - , overrideGhcUserOptions -- ** Re-exporting convenient stuff , liftIO , module Control.Monad.Reader.Class - , module Control.Monad.Journal.Class ) where -#if __GLASGOW_HASKELL__ < 708 --- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different --- classes before ghc 7.8 -#define DIFFERENT_MONADIO 1 - --- RWST doen't have a MonadIO instance before ghc 7.8 -#define MONADIO_INSTANCES 1 -#endif - - import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.CabalApi +import Language.Haskell.GhcMod.CabalConfig import qualified Language.Haskell.GhcMod.Gap as Gap -import DynFlags import GHC import qualified GHC as G import GHC.Paths (libdir) @@ -69,154 +55,36 @@ import HscTypes -- So, RWST automatically becomes an instance of MonadIO. import MonadUtils -#if DIFFERENT_MONADIO -import Control.Monad.Trans.Class (lift) -import qualified Control.Monad.IO.Class -import Data.Monoid (Monoid) -#endif - -import Control.Applicative (Alternative) import Control.Arrow (first) -import Control.Monad (MonadPlus, void) +import Control.Monad (void) #if !MIN_VERSION_monad_control(1,0,0) import Control.Monad (liftM) #endif -import Control.Monad.Base (MonadBase, liftBase) +import Control.Monad.Base (liftBase) --- Monad transformer stuff -import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, - control, liftBaseOp, liftBaseOp_) - -import Control.Monad.Trans.Class import Control.Monad.Reader.Class -import Control.Monad.Writer.Class (MonadWriter) import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Error (ErrorT, runErrorT) -import Control.Monad.Reader (ReaderT, runReaderT) -import Control.Monad.State.Strict (StateT, runStateT) -import Control.Monad.Trans.Journal (JournalT, runJournalT) -#ifdef MONADIO_INSTANCES -import Control.Monad.Trans.Maybe (MaybeT) -import Control.Monad.Error (Error(..)) -#endif -import Control.Monad.Journal.Class +import Control.Monad.Error (runErrorT) +import Control.Monad.Reader (runReaderT) +import Control.Monad.State.Strict (runStateT) +import Control.Monad.Trans.Journal (runJournalT) import Data.Maybe (isJust) -import Data.IORef (IORef, readIORef, writeIORef, newIORef) +import Data.IORef import System.Directory (getCurrentDirectory) ---------------------------------------------------------------- -data GhcModEnv = GhcModEnv { - gmGhcSession :: !(IORef HscEnv) - , gmOptions :: Options - , gmCradle :: Cradle - } - -type GhcModLog = () - -data GhcModState = GhcModState { - gmCompilerMode :: CompilerMode - } deriving (Eq,Show,Read) - -data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read) - -defaultState :: GhcModState -defaultState = GhcModState Simple - ----------------------------------------------------------------- - --- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT' --- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that --- means you can run (almost) all functions from the GHC API on top of 'GhcModT' --- transparently. --- --- The inner monad @m@ should have instances for 'MonadIO' and --- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@ --- monads already have 'MonadBaseControl' 'IO' instances, see the --- @monad-control@ package. -newtype GhcModT m a = GhcModT { - unGhcModT :: StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) a - } deriving ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus -#if DIFFERENT_MONADIO - , Control.Monad.IO.Class.MonadIO -#endif - , MonadReader GhcModEnv -- TODO: make MonadReader instance - -- pass-through like MonadState - , MonadWriter w - , MonadError GhcModError - ) - -instance MonadIO m => MonadIO (GhcModT m) where - liftIO action = do - res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action - case res of - Right a -> return a - - Left e | isIOError e -> - throwError $ GMEIOException (fromEx e :: IOError) - Left e | isGhcModError e -> - throwError $ (fromEx e :: GhcModError) - Left e -> throw e - - where - fromEx :: Exception e => SomeException -> e - fromEx se = let Just e = fromException se in e - isIOError se = - case fromException se of - Just (_ :: IOError) -> True - Nothing -> False - - isGhcModError se = - case fromException se of - Just (_ :: GhcModError) -> True - Nothing -> False - - -instance MonadTrans (GhcModT) where - lift = GhcModT . lift . lift . lift . lift - -instance MonadState s m => MonadState s (GhcModT m) where - get = GhcModT $ lift $ lift $ lift get - put = GhcModT . lift . lift . lift . put - state = GhcModT . lift . lift . lift . state - - -#if MONADIO_INSTANCES -instance MonadIO m => MonadIO (StateT s m) where - liftIO = lift . liftIO - -instance MonadIO m => MonadIO (ReaderT r m) where - liftIO = lift . liftIO - -instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where - liftIO = lift . liftIO - -instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where - liftIO = lift . liftIO - -instance MonadIO m => MonadIO (MaybeT m) where - liftIO = lift . liftIO -#endif - ----------------------------------------------------------------- - -- | Initialize the 'DynFlags' relating to the compilation of a single -- file or GHC session according to the 'Cradle' and 'Options' -- provided. -initializeFlagsWithCradle :: (IOish m, GhcMonad m, MonadError GhcModError m) +initializeFlagsWithCradle :: (IOish m, GhcMonad m, GmError m, GmLog m) => Options -> Cradle + -> CabalConfig -> m () -initializeFlagsWithCradle opt c +initializeFlagsWithCradle opt c config | cabal = withCabal | otherwise = withSandbox where @@ -228,8 +96,8 @@ initializeFlagsWithCradle opt c withCabal = do let Just cabalFile = mCabalFile - pkgDesc <- parseCabalFile c cabalFile - compOpts <- getCompilerOptions ghcopts c pkgDesc + pkgDesc <- parseCabalFile config cabalFile + compOpts <- getCompilerOptions ghcopts c config pkgDesc initSession CabalPkg opt compOpts withSandbox = initSession SingleFile opt compOpts @@ -283,8 +151,9 @@ runGhcModT opt action = gbracket newEnv delEnv $ \env -> do r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do dflags <- getSessionDynFlags defaultCleanupHandler dflags $ do - initializeFlagsWithCradle opt (gmCradle env) - action) + config <- cabalGetConfig =<< cradle + initializeFlagsWithCradle opt (gmCradle env) config + action ) return r where @@ -298,7 +167,7 @@ hoistGhcModT :: IOish m => (Either GhcModError a, GhcModLog) -> GhcModT m a hoistGhcModT (r,l) = do - GhcModT (lift $ lift $ journal l) >> case r of + gmJournal l >> case r of Left e -> throwError e Right a -> return a @@ -328,18 +197,6 @@ withTempSession action = do liftIO $ writeIORef session savedHscEnv return a --- | This is a very ugly workaround don't use it. -overrideGhcUserOptions :: IOish m => ([GHCOption] -> GhcModT m b) -> GhcModT m b -overrideGhcUserOptions action = withTempSession $ do - env <- ask - opt <- options - let ghcOpts = ghcUserOptions opt - opt' = opt { ghcUserOptions = [] } - - initializeFlagsWithCradle opt' (gmCradle env) - - action ghcOpts - ---------------------------------------------------------------- gmeAsk :: IOish m => GhcModT m GhcModEnv @@ -373,113 +230,3 @@ withOptions changeOpt action = local changeEnv action opt = gmOptions e ---------------------------------------------------------------- - -instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where - liftBase = GhcModT . liftBase - -#if MIN_VERSION_monad_control(1,0,0) - -instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where - type StM (GhcModT m) a = - StM (StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) ) a - liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> - f $ runInBase . unGhcModT - - restoreM = GhcModT . restoreM - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} - -#else - -instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where - newtype StM (GhcModT m) a = StGhcMod { - unStGhcMod :: StM (StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) ) a } - liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> - f $ liftM StGhcMod . runInBase . unGhcModT - - restoreM = GhcModT . restoreM . unStGhcMod - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} - -#endif - --- GHC cannot prove the following instances to be decidable automatically using --- the FlexibleContexts extension as they violate the second Paterson Condition, --- namely that: The assertion has fewer constructors and variables (taken --- together and counting repetitions) than the head. Specifically the --- @MonadBaseControl IO m@ constraint is causing this violation. --- --- Proof of termination: --- --- Assuming all constraints containing the variable `m' exist and are decidable --- we show termination by manually replacing the current set of constraints with --- their own set of constraints and show that this, after a finite number of --- steps, results in the empty set, i.e. not having to check any more --- constraints. --- --- We start by setting the constraints to be those immediate constraints of the --- instance declaration which cannot be proven decidable automatically for the --- type under consideration. --- --- @ --- { MonadBaseControl IO m } --- @ --- --- Classes used: --- --- * @class MonadBase b m => MonadBaseControl b m@ --- --- @ --- { MonadBase IO m } --- @ --- --- Classes used: --- --- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@ --- --- @ --- { Applicative IO, Applicative m, Monad IO, Monad m } --- @ --- --- Classes used: --- --- * @class Monad m@ --- * @class Applicative f => Functor f@ --- --- @ --- { Functor m } --- @ --- --- Classes used: --- --- * @class Functor f@ --- --- @ --- { } --- @ --- ∎ - -instance (Functor m, MonadIO m, MonadBaseControl IO m) - => GhcMonad (GhcModT m) where - getSession = (liftIO . readIORef) . gmGhcSession =<< ask - setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask - -#if __GLASGOW_HASKELL__ >= 706 -instance (Functor m, MonadIO m, MonadBaseControl IO m) - => HasDynFlags (GhcModT m) where - getDynFlags = getSessionDynFlags -#endif - -instance (MonadIO m, MonadBaseControl IO m) - => ExceptionMonad (GhcModT m) where - gcatch act handler = control $ \run -> - run act `gcatch` (run . handler) - - gmask = liftBaseOp gmask . liftRestore - where liftRestore f r = f $ liftBaseOp_ r diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs new file mode 100644 index 0000000..0cd2494 --- /dev/null +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.Haskell.GhcMod.Monad.Types where + + +#if __GLASGOW_HASKELL__ < 708 +-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different +-- classes before ghc 7.8 +#define DIFFERENT_MONADIO 1 + +-- RWST doen't have a MonadIO instance before ghc 7.8 +#define MONADIO_INSTANCES 1 +#endif + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Error + +import GHC +import DynFlags +import GhcMonad hiding (withTempSession) +#if __GLASGOW_HASKELL__ <= 702 +import HscTypes +#endif + +-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. +-- RWST does not automatically become an instance of MonadIO. +-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. +-- So, RWST automatically becomes an instance of MonadIO. +import MonadUtils + +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus) +import Control.Monad.Error (ErrorT) +import Control.Monad.Reader (ReaderT) +import Control.Monad.State.Strict (StateT) +import Control.Monad.Trans.Journal (JournalT) + +import Control.Monad.Base (MonadBase, liftBase) +import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, + control, liftBaseOp, liftBaseOp_) + +import Control.Monad.Trans.Class +import Control.Monad.Reader.Class +import Control.Monad.Writer.Class (MonadWriter) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Journal.Class (MonadJournal(..)) + +#ifdef MONADIO_INSTANCES +import Control.Monad.Trans.Maybe (MaybeT) +import Control.Monad.Error (Error(..)) +#endif + +#if DIFFERENT_MONADIO +import Control.Monad.Trans.Class (lift) +import qualified Control.Monad.IO.Class +import Data.Monoid (Monoid) +#endif + +#if !MIN_VERSION_monad_control(1,0,0) +import Control.Monad (liftM) +#endif + +import Data.Monoid +import Data.IORef + +data GhcModEnv = GhcModEnv { + gmGhcSession :: !(IORef HscEnv) + , gmOptions :: Options + , gmCradle :: Cradle + } + +data GhcModLog = GhcModLog { + gmLogMessages :: [String] + } deriving (Eq, Show, Read) + +instance Monoid GhcModLog where + mempty = GhcModLog mempty + GhcModLog a `mappend` GhcModLog b = GhcModLog (a `mappend` b) + +data GhcModState = GhcModState { + gmCompilerMode :: CompilerMode + } deriving (Eq,Show,Read) + +data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read) + +defaultState :: GhcModState +defaultState = GhcModState Simple + +---------------------------------------------------------------- + +-- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT' +-- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that +-- means you can run (almost) all functions from the GHC API on top of 'GhcModT' +-- transparently. +-- +-- The inner monad @m@ should have instances for 'MonadIO' and +-- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@ +-- monads already have 'MonadBaseControl' 'IO' instances, see the +-- @monad-control@ package. +newtype GhcModT m a = GhcModT { + unGhcModT :: StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) a + } deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus +#if DIFFERENT_MONADIO + , Control.Monad.IO.Class.MonadIO +#endif + , MonadReader GhcModEnv -- TODO: make MonadReader instance + -- pass-through like MonadState + , MonadWriter w + , MonadError GhcModError + ) + +instance MonadIO m => MonadIO (GhcModT m) where + liftIO action = do + res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action + case res of + Right a -> return a + + Left e | isIOError e -> + throwError $ GMEIOException (fromEx e :: IOError) + Left e | isGhcModError e -> + throwError $ (fromEx e :: GhcModError) + Left e -> throw e + + where + fromEx :: Exception e => SomeException -> e + fromEx se = let Just e = fromException se in e + + isIOError se = + case fromException se of + Just (_ :: IOError) -> True + Nothing -> False + + isGhcModError se = + case fromException se of + Just (_ :: GhcModError) -> True + Nothing -> False + +instance (Monad m) => MonadJournal GhcModLog (GhcModT m) where + journal !w = GhcModT $ lift $ lift $ (journal w) + history = GhcModT $ lift $ lift $ history + clear = GhcModT $ lift $ lift $ clear + +instance MonadTrans GhcModT where + lift = GhcModT . lift . lift . lift . lift + +instance MonadState s m => MonadState s (GhcModT m) where + get = GhcModT $ lift $ lift $ lift get + put = GhcModT . lift . lift . lift . put + state = GhcModT . lift . lift . lift . state + +#if MONADIO_INSTANCES +instance MonadIO m => MonadIO (StateT s m) where + liftIO = lift . liftIO + +instance MonadIO m => MonadIO (ReaderT r m) where + liftIO = lift . liftIO + +instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where + liftIO = lift . liftIO + +instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where + liftIO = lift . liftIO + +instance MonadIO m => MonadIO (MaybeT m) where + liftIO = lift . liftIO +#endif + + +instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where + liftBase = GhcModT . liftBase + +#if MIN_VERSION_monad_control(1,0,0) + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where + type StM (GhcModT m) a = + StM (StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) ) a + liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> + f $ runInBase . unGhcModT + + restoreM = GhcModT . restoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +#else + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where + newtype StM (GhcModT m) a = StGhcMod { + unStGhcMod :: StM (StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) ) a } + liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> + f $ liftM StGhcMod . runInBase . unGhcModT + + restoreM = GhcModT . restoreM . unStGhcMod + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +#endif + +-- GHC cannot prove the following instances to be decidable automatically using +-- the FlexibleContexts extension as they violate the second Paterson Condition, +-- namely that: The assertion has fewer constructors and variables (taken +-- together and counting repetitions) than the head. Specifically the +-- @MonadBaseControl IO m@ constraint is causing this violation. +-- +-- Proof of termination: +-- +-- Assuming all constraints containing the variable `m' exist and are decidable +-- we show termination by manually replacing the current set of constraints with +-- their own set of constraints and show that this, after a finite number of +-- steps, results in the empty set, i.e. not having to check any more +-- constraints. +-- +-- We start by setting the constraints to be those immediate constraints of the +-- instance declaration which cannot be proven decidable automatically for the +-- type under consideration. +-- +-- @ +-- { MonadBaseControl IO m } +-- @ +-- +-- Classes used: +-- +-- * @class MonadBase b m => MonadBaseControl b m@ +-- +-- @ +-- { MonadBase IO m } +-- @ +-- +-- Classes used: +-- +-- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@ +-- +-- @ +-- { Applicative IO, Applicative m, Monad IO, Monad m } +-- @ +-- +-- Classes used: +-- +-- * @class Monad m@ +-- * @class Applicative f => Functor f@ +-- +-- @ +-- { Functor m } +-- @ +-- +-- Classes used: +-- +-- * @class Functor f@ +-- +-- @ +-- { } +-- @ +-- ∎ + +instance (Functor m, MonadIO m, MonadBaseControl IO m) + => GhcMonad (GhcModT m) where + getSession = (liftIO . readIORef) . gmGhcSession =<< ask + setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask + +#if __GLASGOW_HASKELL__ >= 706 +instance (Functor m, MonadIO m, MonadBaseControl IO m) + => HasDynFlags (GhcModT m) where + getDynFlags = getSessionDynFlags +#endif + +instance (MonadIO m, MonadBaseControl IO m) + => ExceptionMonad (GhcModT m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index eac0775..68c75aa 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -1,14 +1,15 @@ {-# LANGUAGE BangPatterns, TupleSections #-} module Language.Haskell.GhcMod.PathsAndFiles where -import Config (cProjectVersion, cTargetPlatformString) +import Config (cProjectVersion) import Control.Applicative import Control.Monad import Data.List -import Data.List.Split (splitOn) import Data.Char import Data.Maybe import Data.Traversable (traverse) +import Distribution.System (buildPlatform) +import Distribution.Text (display) import Language.Haskell.GhcMod.Types import System.Directory import System.FilePath @@ -88,7 +89,6 @@ findCabalSandboxDir dir = do where isSandboxConfig = (=="cabal.sandbox.config") - appendDir :: DirPath -> [FileName] -> [FilePath] appendDir d fs = (d ) `map` fs @@ -164,6 +164,10 @@ ghcSandboxPkgDbDir = packageCache :: String packageCache = "package.cache" +-- | Filename of the show'ed Cabal setup-config cache +prettyConfigCache :: FilePath +prettyConfigCache = setupConfigPath <.> "ghc-mod-0.pretty-cabal-cache" + -- | Filename of the symbol table cache file. symbolCache :: Cradle -> FilePath symbolCache crdl = cradleTempDir crdl symbolCacheFile diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs index 83b874f..2779627 100644 --- a/Language/Haskell/GhcMod/World.hs +++ b/Language/Haskell/GhcMod/World.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards, CPP #-} module Language.Haskell.GhcMod.World where {-( , World @@ -12,7 +12,8 @@ import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils -import Control.Applicative (pure,(<$>),(<*>)) +import Control.Applicative (pure, (<$>), (<*>)) +import Control.Monad import Data.Maybe import Data.Traversable (traverse) import System.Directory (getModificationTime) @@ -45,6 +46,8 @@ data World = World { worldPackageCaches :: [TimedFile] , worldCabalFile :: Maybe TimedFile , worldCabalConfig :: Maybe TimedFile + , worldSymbolCache :: Maybe TimedFile + , worldPrettyCabalConfigCache :: Maybe TimedFile } deriving (Eq, Show) timedPackageCache :: Cradle -> IO [TimedFile] @@ -57,15 +60,23 @@ getCurrentWorld :: Cradle -> IO World getCurrentWorld crdl = do pkgCaches <- timedPackageCache crdl mCabalFile <- timeFile `traverse` cradleCabalFile crdl - mSetupConfig <- mightExist (setupConfigFile crdl) - mCabalConfig <- timeFile `traverse` mSetupConfig + mCabalConfig <- timeMaybe (setupConfigFile crdl) + mSymbolCache <- timeMaybe (symbolCache crdl) + mPrettyConfigCache <- timeMaybe prettyConfigCache return World { worldPackageCaches = pkgCaches , worldCabalFile = mCabalFile , worldCabalConfig = mCabalConfig + , worldSymbolCache = mSymbolCache + , worldPrettyCabalConfigCache = mPrettyConfigCache } + where + timeMaybe :: FilePath -> IO (Maybe TimedFile) + timeMaybe f = do + join $ (timeFile `traverse`) <$> mightExist f + didWorldChange :: World -> Cradle -> IO Bool didWorldChange world crdl = do (world /=) <$> getCurrentWorld crdl @@ -83,7 +94,11 @@ didWorldChange world crdl = do -- -- * Both files exist -- @Just cc < Just cf = cc < cf = cc `olderThan` cf@ -isSetupConfigOutOfDate :: Cradle -> IO Bool -isSetupConfigOutOfDate crdl = do - world <- getCurrentWorld crdl - return $ worldCabalConfig world < worldCabalFile world +isSetupConfigOutOfDate :: World -> Bool +isSetupConfigOutOfDate World {..} = do + worldCabalConfig < worldCabalFile + +isYoungerThanSetupConfig :: FilePath -> World -> IO Bool +isYoungerThanSetupConfig file World {..} = do + tfile <- timeFile file + return $ worldCabalConfig < Just tfile diff --git a/Setup.hs b/Setup.hs index cd6f34e..a53920c 100755 --- a/Setup.hs +++ b/Setup.hs @@ -130,7 +130,7 @@ sanityCheckCabalVersions args cf desc lbi = do minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10") when minGhc710 $ do - let cabalHelperCabalVer = compCabalVer CLibName + let cabalHelperCabalVer = compCabalVer (CExeName "cabal-helper") when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $ failCabalVersionDifferent cabalVer cabalHelperCabalVer diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 1fe41be..bd7c082 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -66,11 +66,13 @@ Library Default-Extensions: ConstraintKinds, FlexibleContexts Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Internal - Other-Modules: Language.Haskell.GhcMod.Boot + Other-Modules: Paths_ghc_mod + Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Browse Language.Haskell.GhcMod.CabalConfig.Cabal16 Language.Haskell.GhcMod.CabalConfig.Cabal18 - Language.Haskell.GhcMod.CabalConfig.Cabal21 + Language.Haskell.GhcMod.CabalConfig.Cabal22 + Language.Haskell.GhcMod.CabalConfig.Extract Language.Haskell.GhcMod.CabalConfig Language.Haskell.GhcMod.CabalApi Language.Haskell.GhcMod.CaseSplit @@ -91,8 +93,10 @@ Library Language.Haskell.GhcMod.Lang Language.Haskell.GhcMod.Lint Language.Haskell.GhcMod.Logger + Language.Haskell.GhcMod.Logging Language.Haskell.GhcMod.Modules Language.Haskell.GhcMod.Monad + Language.Haskell.GhcMod.Monad.Types Language.Haskell.GhcMod.PathsAndFiles Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.Read @@ -102,13 +106,9 @@ Library Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.World - if impl(ghc >= 7.10) - Other-Modules: Language.Haskell.GhcMod.CabalConfig.Ghc710 - else - Other-Modules: Language.Haskell.GhcMod.CabalConfig.PreGhc710 - Build-Depends: base >= 4.0 && < 5 + , bytestring , containers , deepseq , directory From 48563a435e3edac621fd0611ad0a8e328753e6ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 8 Feb 2015 14:17:53 +0100 Subject: [PATCH 016/207] Use crazy TemplateHaskell magic for Setup.hs backwards compatibility --- NotCPP/COPYING | 30 ++++++ NotCPP/Declarations.hs | 146 +++++++++++++++++++++++++++ NotCPP/LookupValueName.hs | 38 +++++++ NotCPP/OrphanEvasion.hs | 114 +++++++++++++++++++++ NotCPP/ScopeLookup.hs | 65 ++++++++++++ NotCPP/Utils.hs | 29 ++++++ Setup.hs | 15 ++- SetupCompat.hs | 204 ++++++++++++++++++++++++++------------ 8 files changed, 567 insertions(+), 74 deletions(-) create mode 100644 NotCPP/COPYING create mode 100644 NotCPP/Declarations.hs create mode 100644 NotCPP/LookupValueName.hs create mode 100644 NotCPP/OrphanEvasion.hs create mode 100644 NotCPP/ScopeLookup.hs create mode 100644 NotCPP/Utils.hs diff --git a/NotCPP/COPYING b/NotCPP/COPYING new file mode 100644 index 0000000..9eb8e81 --- /dev/null +++ b/NotCPP/COPYING @@ -0,0 +1,30 @@ +Copyright Ben Millwood 2012 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ben Millwood nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/NotCPP/Declarations.hs b/NotCPP/Declarations.hs new file mode 100644 index 0000000..7ae4188 --- /dev/null +++ b/NotCPP/Declarations.hs @@ -0,0 +1,146 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE CPP #-} +-- Using CPP so you don't have to :) +module NotCPP.Declarations where + +import Control.Arrow +import Control.Applicative +import Data.Maybe +import Language.Haskell.TH.Syntax hiding (lookupName) + +import NotCPP.LookupValueName + +nT :: Monad m => String -> m Type +cT :: Monad m => String -> m Type +nE :: Monad m => String -> m Exp +nP :: Monad m => String -> m Pat + +nT str = return $ VarT (mkName str) +cT str = return $ ConT (mkName str) +nE str = return $ VarE (mkName str) +nP str = return $ VarP (mkName str) +recUpdE' :: Q Exp -> Name -> Exp -> Q Exp +recUpdE' ex name assign = do + RecUpdE <$> ex <*> pure [(name, assign)] + +lookupName :: (NameSpace, String) -> Q (Maybe Name) +lookupName (VarName, n) = lookupValueName n +lookupName (DataName, n) = lookupValueName n +lookupName (TcClsName, n) = lookupTypeName n + +-- Does this even make sense? +ifelseD :: Q [Dec] -> Q [Dec] -> Q [Dec] +ifelseD if_decls' else_decls = do + if_decls <- if_decls' + alreadyDefined <- definedNames (boundNames `concatMap` if_decls) + case alreadyDefined of + [] -> if_decls' + _ -> else_decls + +ifdefelseD, ifelsedefD :: String -> Q [Dec] -> Q [Dec] -> Q [Dec] +ifelsedefD = ifdefelseD +ifdefelseD ident if_decls else_decls = do + exists <- isJust <$> lookupValueName ident + if exists + then if_decls + else else_decls + +ifdefD :: String -> Q [Dec] -> Q [Dec] +ifdefD ident decls = ifdefelseD ident decls (return []) + +ifndefD :: String -> Q [Dec] -> Q [Dec] +ifndefD ident decls = ifdefelseD ident (return []) decls + +-- | Each of the given declarations is only spliced if the identifier it defines +-- is not defined yet. +-- +-- For example: +-- +-- @$(ifD [[d| someFunctionThatShouldExist x = x+1 |]]@ +-- +-- If @someFunctionThatShouldExist@ doesn't actually exist the definition given +-- in the splice will be the result of the splice otherwise nothing will be +-- spliced. +-- +-- Currently this only works for function declarations but it can be easily +-- extended to other kinds of declarations. +ifD :: Q [Dec] -> Q [Dec] +ifD decls' = do + decls <- decls' + concat <$> flip mapM decls (\decl -> do + alreadyDefined <- definedNames (boundNames decl) + case alreadyDefined of + [] -> return [decl] + _ -> return []) + +definedNames :: [(NameSpace, Name)] -> Q [Name] +definedNames ns = catMaybes <$> (lookupName . second nameBase) `mapM` ns + +boundNames :: Dec -> [(NameSpace, Name)] +boundNames decl = + case decl of + SigD n _ -> [(VarName, n)] + FunD n _cls -> [(VarName, n)] + InfixD _ n -> [(VarName, n)] + ValD p _ _ -> map ((,) VarName) $ patNames p + + TySynD n _ _ -> [(TcClsName, n)] + ClassD _ n _ _ _ -> [(TcClsName, n)] + FamilyD _ n _ _ -> [(TcClsName, n)] + + DataD _ n _ ctors _ -> + [(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors) + + NewtypeD _ n _ ctor _ -> + [(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor) + + DataInstD _ _n _ ctors _ -> + map ((,) TcClsName) (conNames `concatMap` ctors) + + NewtypeInstD _ _n _ ctor _ -> + map ((,) TcClsName) (conNames ctor) + + InstanceD _ _ty _ -> + error "notcpp: Instance declarations are not supported yet" + ForeignD _ -> + error "notcpp: Foreign declarations are not supported yet" + PragmaD _pragma -> error "notcpp: pragmas are not supported yet" + +#if __GLASGOW_HASKELL__ >= 708 + TySynInstD _n _ -> error "notcpp: TySynInstD not supported yet" +#else + TySynInstD _n _ _ -> error "notcpp: TySynInstD not supported yet" +#endif + +#if __GLASGOW_HASKELL__ >= 708 + ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)] + RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet" +#endif + +conNames :: Con -> [Name] +conNames con = + case con of + NormalC n _ -> [n] + RecC n _ -> [n] + InfixC _ n _ -> [n] + ForallC _ _ c -> conNames c + +patNames :: Pat -> [Name] +patNames p'' = + case p'' of + LitP _ -> [] + VarP n -> [n] + TupP ps -> patNames `concatMap` ps + UnboxedTupP ps -> patNames `concatMap` ps + ConP _ ps -> patNames `concatMap` ps + InfixP p _ p' -> patNames `concatMap` [p,p'] + UInfixP p _ p' -> patNames `concatMap` [p,p'] + ParensP p -> patNames p + TildeP p -> patNames p + BangP p -> patNames p + AsP n p -> n:(patNames p) + WildP -> [] + RecP _ fps -> patNames `concatMap` map snd fps + ListP ps -> patNames `concatMap` ps + SigP p _ -> patNames p + ViewP _ p -> patNames p diff --git a/NotCPP/LookupValueName.hs b/NotCPP/LookupValueName.hs new file mode 100644 index 0000000..72462c2 --- /dev/null +++ b/NotCPP/LookupValueName.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | This module uses scope lookup techniques to either export +-- 'lookupValueName' from @Language.Haskell.TH@, or define +-- its own 'lookupValueName', which attempts to do the +-- same job with just 'reify'. This will sometimes fail, but if it +-- succeeds it will give the answer that the real function would have +-- given. +-- +-- The idea is that if you use lookupValueName from this module, +-- your client code will automatically use the best available name +-- lookup mechanism. This means that e.g. 'scopeLookup' can work +-- very well on recent GHCs and less well but still somewhat +-- usefully on older GHCs. +module NotCPP.LookupValueName ( + lookupValueName + ) where + +import Language.Haskell.TH + +import NotCPP.Utils + +bestValueGuess :: String -> Q (Maybe Name) +bestValueGuess s = do + mi <- maybeReify (mkName s) + case mi of + Nothing -> no + Just i -> case i of + VarI n _ _ _ -> yes n + DataConI n _ _ _ -> yes n + _ -> err ["unexpected info:", show i] + where + no = return Nothing + yes = return . Just + err = fail . showString "NotCPP.bestValueGuess: " . unwords + +$(recover [d| lookupValueName = bestValueGuess |] $ do + VarI _ _ _ _ <- reify (mkName "lookupValueName") + return []) diff --git a/NotCPP/OrphanEvasion.hs b/NotCPP/OrphanEvasion.hs new file mode 100644 index 0000000..d666d7b --- /dev/null +++ b/NotCPP/OrphanEvasion.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-} +-- | +-- The orphan instance problem is well-known in Haskell. This module +-- by no means purports to solve the problem, but provides a workaround +-- that may be significantly less awful than the status quo in some +-- cases. +-- +-- Say I think that the 'Name' type should have an 'IsString' instance. +-- But I don't control either the class or the type, so if I define the +-- instance, and then the template-haskell package defines one, my code +-- is going to break. +-- +-- 'safeInstance' can help me to solve this problem: +-- +-- > safeInstance ''IsString [t| Name |] [d| +-- > fromString = mkName |] +-- +-- This will declare an instance only if one doesn't already exist. +-- Now anyone importing your module is guaranteed to get an instance +-- one way or the other. +-- +-- This module is still highly experimental. The example given above +-- does work, but anything involving type variables or complex method +-- bodies may be less fortunate. The names of the methods are mangled +-- a bit, so using recursion to define them may not work. Define the +-- method outside the code and then use a simple binding as above. +-- +-- If you use this code (successfully or unsuccessfully!), go fetch +-- the maintainer address from the cabal file and let me know! +module NotCPP.OrphanEvasion ( + MultiParams, + safeInstance, + safeInstance', + ) where + +import Control.Applicative + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import NotCPP.ScopeLookup + +-- | An empty type used only to signify a multiparameter typeclass in +-- 'safeInstance'. +data MultiParams a + +-- | Given @(forall ts. Cxt => t)@, return @(Cxt, [t])@. +-- Given @(forall ts. Cxt => 'MultiParams' (t1, t2, t3))@, return +-- @(Cxt, [t1, t2, t3])@. +-- +-- This is used in 'safeInstance' to allow types to be specified more +-- easily with TH typequotes. +fromTuple :: Type -> (Cxt, [Type]) +fromTuple ty = unTuple <$> case ty of + ForallT _ cxt ty' -> (cxt, ty') + _ -> ([], ty) + where + unTuple :: Type -> [Type] + unTuple (AppT (ConT n) ta) + | n == ''MultiParams = case unrollAppT ta of + (TupleT{}, ts) -> ts + _ -> [ty] + unTuple t = [t] + +-- | A helper function to unwind type application. +-- Given @TyCon t1 t2 t3@, returns @(TyCon, [t1,t2,t3])@ +unrollAppT :: Type -> (Type, [Type]) +unrollAppT = go [] + where + go acc (AppT tc ta) = go (ta : acc) tc + go acc ty = (ty, reverse acc) + +-- | Left inverse to unrollAppT, equal to @'foldl' 'AppT'@ +rollAppT :: Type -> [Type] -> Type +rollAppT = foldl AppT + +-- | @'safeInstance'' className cxt types methods@ produces an instance +-- of the given class if and only if one doesn't already exist. +-- +-- See 'safeInstance' for a simple way to construct the 'Cxt' and +-- @['Type']@ parameters. +safeInstance' :: Name -> Cxt -> [Type] -> Q [Dec] -> Q [Dec] +safeInstance' cl cxt tys inst = do + b <- $(scopeLookups ["isInstance", "isClassInstance"]) cl tys + if b + then return [] + else do + ds <- map fixInst <$> inst + return [InstanceD cxt (rollAppT (ConT cl) tys) ds] + where + fixInst (FunD n cls) = FunD (fixName n) cls + fixInst (ValD (VarP n) rhs wh) = ValD (VarP (fixName n)) rhs wh + fixInst d = d + fixName (Name n _) = Name n NameS + +-- | 'safeInstance' is a more convenient version of 'safeInstance'' +-- that takes the context and type from a @'Q' 'Type'@ with the intention +-- that it be supplied using a type-quote. +-- +-- To define an instance @Show a => Show (Wrapper a)@, you'd use: +-- +-- > safeInstance ''Show [t| Show a => Wrapper a |] +-- > [d| show _ = "stuff" |] +-- +-- To define an instance of a multi-param type class, use the +-- 'MultiParams' type constructor with a tuple: +-- +-- > safeInstance ''MonadState +-- > [t| MonadState s m => MultiParams (s, MaybeT m) |] +-- > [d| put = ... |] +safeInstance :: Name -> Q Type -> Q [Dec] -> Q [Dec] +safeInstance n qty inst = do + (cxt, tys) <- fromTuple <$> qty + safeInstance' n cxt tys inst diff --git a/NotCPP/ScopeLookup.hs b/NotCPP/ScopeLookup.hs new file mode 100644 index 0000000..5fb6415 --- /dev/null +++ b/NotCPP/ScopeLookup.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | +-- This module exports 'scopeLookup', which will find a variable or +-- value constructor for you and present it for your use. E.g. at some +-- point in the history of the acid-state package, 'openAcidState' was +-- renamed 'openLocalState'; for compatibility with both, you could +-- use: +-- +-- > openState :: IO (AcidState st) +-- > openState = case $(scopeLookup "openLocalState") of +-- > Just open -> open defaultState +-- > Nothing -> case $(scopeLookup "openAcidState") of +-- > Just open -> open defaultState +-- > Nothing -> error +-- > "openState: runtime name resolution has its drawbacks :/" +-- +-- Or, for this specific case, you can use 'scopeLookups': +-- +-- > openState :: IO (AcidState st) +-- > openState = open defaultState +-- > where +-- > open = $(scopeLookups ["openLocalState","openAcidState"]) +-- +-- Now if neither of the names are found then TH will throw a +-- compile-time error. +module NotCPP.ScopeLookup ( + scopeLookup, + scopeLookups, + scopeLookup', + liftMaybe, + recoverMaybe, + maybeReify, + infoToExp, + ) where + +import Control.Applicative ((<$>)) + +import Language.Haskell.TH (Q, Exp, recover, reify) + +import NotCPP.LookupValueName +import NotCPP.Utils + +-- | Produces a spliceable expression which expands to @'Just' val@ if +-- the given string refers to a value @val@ in scope, or 'Nothing' +-- otherwise. +-- +-- @scopeLookup = 'fmap' 'liftMaybe' . 'scopeLookup''@ +scopeLookup :: String -> Q Exp +scopeLookup = fmap liftMaybe . scopeLookup' + +-- | Finds the first string in the list that names a value, and produces +-- a spliceable expression of that value, or reports a compile error if +-- it fails. +scopeLookups :: [String] -> Q Exp +scopeLookups xs = foldr + (\s r -> maybe r return =<< scopeLookup' s) + (fail ("scopeLookups: none found: " ++ show xs)) + xs + +-- | Produces @'Just' x@ if the given string names the value @x@, +-- or 'Nothing' otherwise. +scopeLookup' :: String -> Q (Maybe Exp) +scopeLookup' s = recover (return Nothing) $ do + Just n <- lookupValueName s + infoToExp <$> reify n diff --git a/NotCPP/Utils.hs b/NotCPP/Utils.hs new file mode 100644 index 0000000..9da7958 --- /dev/null +++ b/NotCPP/Utils.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} +module NotCPP.Utils where + +import Control.Applicative ((<$>)) +import Language.Haskell.TH + +-- | Turns 'Nothing' into an expression representing 'Nothing', and +-- @'Just' x@ into an expression representing 'Just' applied to the +-- expression in @x@. +liftMaybe :: Maybe Exp -> Exp +liftMaybe = maybe (ConE 'Nothing) (AppE (ConE 'Just)) + +-- | A useful variant of 'reify' that returns 'Nothing' instead of +-- halting compilation when an error occurs (e.g. because the given +-- name was not in scope). +maybeReify :: Name -> Q (Maybe Info) +maybeReify = recoverMaybe . reify + +-- | Turns a possibly-failing 'Q' action into one returning a 'Maybe' +-- value. +recoverMaybe :: Q a -> Q (Maybe a) +recoverMaybe q = recover (return Nothing) (Just <$> q) + +-- | Returns @'Just' ('VarE' n)@ if the info relates to a value called +-- @n@, or 'Nothing' if it relates to a different sort of thing. +infoToExp :: Info -> Maybe Exp +infoToExp (VarI n _ _ _) = Just (VarE n) +infoToExp (DataConI n _ _ _) = Just (ConE n) +infoToExp _ = Nothing diff --git a/Setup.hs b/Setup.hs index a53920c..20e34b2 100755 --- a/Setup.hs +++ b/Setup.hs @@ -24,7 +24,7 @@ import SetupCompat main :: IO () main = defaultMainWithHooks $ simpleUserHooks { confHook = \(gpd, hbi) cf -> - xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf + xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf , copyHook = xInstallTargetHook @@ -47,18 +47,15 @@ xBuildDependsLike lbi = ] where - updateClbi deps comp clbi = let - cpdeps = componentPackageDeps clbi - in clbi { - componentPackageDeps = cpdeps `union` otherDeps deps comp - } + updateClbi deps comp clbi = setUnionDeps (otherDeps deps comp) clbi dependsMap :: - LocalBuildInfo -> [(ComponentName, [(InstalledPackageId, PackageId)])] + LocalBuildInfo -> [(ComponentName, Deps)] dependsMap lbi = - second componentPackageDeps <$> allComponentsInBuildOrder lbi + second getDeps <$> allComponentsInBuildOrder lbi - otherDeps deps comp = fromMaybe [] $ + otherDeps :: [(ComponentName, Deps)] -> Component -> Deps + otherDeps deps comp = fromMaybe noDeps $ flip lookup deps =<< read <$> lookup "x-build-depends-like" fields where fields = customFieldsBI (componentBuildInfo comp) diff --git a/SetupCompat.hs b/SetupCompat.hs index b39475d..028dacd 100644 --- a/SetupCompat.hs +++ b/SetupCompat.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE CPP, RecordWildCards, StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell, RecordWildCards, StandaloneDeriving #-} module SetupCompat where +import Control.Arrow import Control.Monad.State.Strict import Data.List import Data.Maybe @@ -9,61 +10,34 @@ import Data.Function import Distribution.Simple.LocalBuildInfo import Distribution.PackageDescription -#if __GLASGOW_HASKELL__ <= 706 -componentsConfigs :: - LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] -componentsConfigs LocalBuildInfo {..} = - (maybe [] (\c -> [(CLibName, c, [])]) libraryConfig) - ++ ((\(n, clbi) -> (CExeName n, clbi, [])) <$> executableConfigs) - ++ ((\(n, clbi) -> (CTestName n, clbi, [])) <$> testSuiteConfigs) - ++ ((\(n, clbi) -> (CBenchName n, clbi, [])) <$> benchmarkConfigs) +import Distribution.Simple +import Distribution.Simple.Setup +import Distribution.Simple.Install -getComponent :: PackageDescription -> ComponentName -> Component -getComponent pkg cname = - case lookupComponent pkg cname of - Just cpnt -> cpnt - Nothing -> missingComponent - where - missingComponent = - error $ "internal error: the package description contains no " - ++ "component corresponding to " ++ show cname +import qualified Data.Map as M -lookupComponent :: PackageDescription -> ComponentName -> Maybe Component -lookupComponent pkg CLibName = - fmap CLib $ library pkg -lookupComponent pkg (CExeName name) = - fmap CExe $ find ((name ==) . exeName) (executables pkg) -lookupComponent pkg (CTestName name) = - fmap CTest $ find ((name ==) . testName) (testSuites pkg) -lookupComponent pkg (CBenchName name) = - fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) --- We're lying here can't be bothered to order these -allComponentsInBuildOrder :: LocalBuildInfo - -> [(ComponentName, ComponentLocalBuildInfo)] -allComponentsInBuildOrder lbi = - [ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ] +import NotCPP.Declarations +import Language.Haskell.TH -getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo -getComponentLocalBuildInfo lbi cname = - case [ clbi - | (cname', clbi, _) <- componentsConfigs lbi - , cname == cname' ] of - [clbi] -> clbi - _ -> missingComponent - where - missingComponent = - error $ "internal error: there is no configuration data " - ++ "for component " ++ show cname +$(ifndefD "componentsConfigs" [d| deriving instance (Ord ComponentName) |] ) -deriving instance (Ord ComponentName) +$(ifelsedefD "componentsConfigs" [d| -setComponentsConfigs + setComponentsConfigs + :: LocalBuildInfo + -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] + -> LocalBuildInfo + setComponentsConfigs lbi cs = $(recUpdE' (nE "lbi") (mkName "componentsConfigs") (VarE $ mkName "cs")) + + |] [d| + + setComponentsConfigs :: LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, a)] -> LocalBuildInfo -setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs - where + setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs + where -- gcs :: [ [(ComponentLocalBuildInfo, ComponentName, a)] ] gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` fst3) cs @@ -79,35 +53,135 @@ setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs sameKind (CBenchName _) _ = False setClbis [(CLibName, clbi, _)] = - get >>= \lbi -> put $ lbi {libraryConfig = Just clbi} + get >>= \lbi -> + put $ $(recUpdE' (nE "lbi") (mkName "libraryConfig") (AppE (ConE (mkName "Just")) (VarE (mkName "clbi")))) setClbis cs@((CExeName _, _, _):_) = let cfg = (\((CExeName n), clbi, _) -> (n, clbi)) <$> cs in - get >>= \lbi -> put $ lbi {executableConfigs = cfg } + get >>= \lbi -> + put $ $(recUpdE' (nE "lbi") (mkName "executableConfigs") (VarE $ mkName "cfg")) setClbis cs@((CTestName _, _, _):_) = let cfg = (\((CTestName n), clbi, _) -> (n, clbi)) <$> cs in - get >>= \lbi -> put $ lbi {testSuiteConfigs = cfg } + get >>= \lbi -> + put $ $(recUpdE' (nE "lbi") (mkName "testSuiteConfigs") (VarE $ mkName "cfg")) setClbis cs@((CBenchName _, _, _):_) = let cfg = (\((CBenchName n), clbi, _) -> (n, clbi)) <$> cs in - get >>= \lbi -> put $ lbi {benchmarkConfigs = cfg } + get >>= \lbi -> + put $ $(recUpdE' (nE "lbi") (mkName "benchmarkConfigs") (VarE $ mkName "cfg")) -#else - -setComponentsConfigs - :: LocalBuildInfo - -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] - -> LocalBuildInfo -setComponentsConfigs lbi cs = lbi { componentsConfigs = cs } - -#endif + |]) -#if __GLASGOW_HASKELL__ <= 704 +$(ifD [d| -componentBuildInfo :: Component -> BuildInfo -componentBuildInfo = - foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo + componentsConfigs :: + LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] + componentsConfigs LocalBuildInfo {..} = + (maybe [] (\c -> [(CLibName, c, [])]) $(nE "libraryConfig")) + ++ ((\(n, clbi) -> (CExeName n, clbi, [])) <$> $(nE "executableConfigs")) + ++ ((\(n, clbi) -> (CTestName n, clbi, [])) <$> $(nE "testSuiteConfigs")) + ++ ((\(n, clbi) -> (CBenchName n, clbi, [])) <$> $(nE "benchmarkConfigs")) -#endif + getComponent :: PackageDescription -> ComponentName -> Component + getComponent pkg cname = + case lookupComponent pkg cname of + Just cpnt -> cpnt + Nothing -> missingComponent + where + missingComponent = + error $ "internal error: the package description contains no " + ++ "component corresponding to " ++ show cname + + lookupComponent :: PackageDescription -> ComponentName -> Maybe Component + lookupComponent pkg CLibName = + fmap CLib $ library pkg + lookupComponent pkg (CExeName name) = + fmap CExe $ find ((name ==) . exeName) (executables pkg) + lookupComponent pkg (CTestName name) = + fmap CTest $ find ((name ==) . testName) (testSuites pkg) + lookupComponent pkg (CBenchName name) = + fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) + +-- We're lying here can't be bothered to order these + allComponentsInBuildOrder :: LocalBuildInfo + -> [(ComponentName, ComponentLocalBuildInfo)] + allComponentsInBuildOrder lbi = + [ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ] + + getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo + getComponentLocalBuildInfo lbi cname = + case [ clbi + | (cname', clbi, _) <- componentsConfigs lbi + , cname == cname' ] of + [clbi] -> clbi + _ -> missingComponent + where + missingComponent = + error $ "internal error: there is no configuration data " + ++ "for component " ++ show cname + + componentBuildInfo :: Component -> BuildInfo + componentBuildInfo = + foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo + + |]) + + +$(ifelsedefD "componentPackageRenaming" [d| + + type Deps = ([(InstalledPackageId, PackageId)], M.Map PackageName $(cT "ModuleRenaming")) + + noDeps = ([], M.empty) + + getDeps :: ComponentLocalBuildInfo -> Deps + getDeps = componentPackageDeps &&& $(nE "componentPackageRenaming") + + setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo + setUnionDeps (deps, rns) clbi = let + clbi' = setComponentPackageRenaming clbi rns + cpdeps = componentPackageDeps clbi + in + clbi' { + componentPackageDeps = cpdeps `union` deps + } + + setComponentPackageRenaming clbi cprn = + -- [| clbi { componentPackageRenaming = componentPackageRenaming clbi `M.union` cprn } |] + $(recUpdE' + (nE "clbi") + (mkName "componentPackageRenaming") + (InfixE + (Just + (AppE + (VarE + (mkName "componentPackageRenaming")) + (VarE (mkName "clbi")) + )) + (VarE (mkName "M.union")) + (Just (VarE (mkName "cprn"))) + ) + ) + + |] [d| + + type Deps = [(InstalledPackageId, PackageId)] + + noDeps = [] + + getDeps :: ComponentLocalBuildInfo -> Deps + getDeps lbi = componentPackageDeps lbi + + setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo + setUnionDeps deps clbi = let + cpdeps = componentPackageDeps clbi + in + clbi { + componentPackageDeps = cpdeps `union` deps + } + + +-- setComponentPackageRenaming clbi _cprn = clbi + + |]) From 52e3233f4459bd1dc178304b70b7fb92c00032b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 1 Mar 2015 04:51:22 +0100 Subject: [PATCH 017/207] Introducing cabal-helper-wrapper The idea here is to build cabal-helper with whatever version of Cabal the user happens to be using (which we find by looking at dist/setup-config) at runtime. This way we can support literally any version of Cabal as long as the actual cabal-helper still compiles. I tried to only use interfaces in Cabal that have been there since at least 1.16 so I'm hoping this shouldn't break too much. --- cabal-helper/Common.hs | 41 +++++ cabal-helper/Main.hs | 345 ++++++++++++++++++++++++++++++++++++++++ cabal-helper/Wrapper.hs | 258 ++++++++++++++++++++++++++++++ ghc-mod.cabal | 19 ++- src/GHCModCabal.hs | 28 ---- 5 files changed, 656 insertions(+), 35 deletions(-) create mode 100644 cabal-helper/Common.hs create mode 100644 cabal-helper/Main.hs create mode 100644 cabal-helper/Wrapper.hs delete mode 100644 src/GHCModCabal.hs diff --git a/cabal-helper/Common.hs b/cabal-helper/Common.hs new file mode 100644 index 0000000..ed58f81 --- /dev/null +++ b/cabal-helper/Common.hs @@ -0,0 +1,41 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +module Common where + +import Control.Applicative +import Data.List +import Data.Maybe +import System.Environment +import System.IO + +errMsg :: String -> IO () +errMsg str = do + prog <- getProgName + hPutStrLn stderr $ prog ++ ": " ++ str + +align :: String -> String -> String -> String +align n an str = let + h:rest = lines str + [hm] = match n h + rest' = [ move (hm - rm) r | r <- rest, rm <- match an r] + in + unlines (h:rest') + where + match p str' = maybeToList $ + fst <$> find ((p `isPrefixOf`) . snd) ([0..] `zip` tails str') + move i str' | i > 0 = replicate i ' ' ++ str' + move i str' = drop i str' diff --git a/cabal-helper/Main.hs b/cabal-helper/Main.hs new file mode 100644 index 0000000..a405d1e --- /dev/null +++ b/cabal-helper/Main.hs @@ -0,0 +1,345 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE CPP, BangPatterns, RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} +import Distribution.Simple.Utils (cabalVersion) +import Distribution.Simple.Configure + +import Distribution.Package (PackageIdentifier, InstalledPackageId, PackageId) +import Distribution.PackageDescription (PackageDescription, + FlagAssignment, + Executable(..), + Library(..), + TestSuite(..), + Benchmark(..), + BuildInfo(..), + TestSuiteInterface(..), + BenchmarkInterface(..), + withLib) +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) + +import Distribution.Simple.Configure (getPersistBuildConfig) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), + Component(..), + ComponentName(..), + ComponentLocalBuildInfo(..), + componentBuildInfo, + externalPackageDeps, + withComponentsLBI, + inplacePackageId) + +import Distribution.Simple.GHC (componentGhcOptions) +import Distribution.Simple.Program.GHC (GhcOptions(..), renderGhcOptions) + +import Distribution.Simple.Setup (ConfigFlags(..),Flag(..)) +import Distribution.Simple.Build (initialBuildSteps) +import Distribution.Simple.BuildPaths (autogenModuleName, cppHeaderName, exeExtension) +import Distribution.Simple.Compiler (PackageDB(..)) + +import Distribution.ModuleName (components) +import qualified Distribution.ModuleName as C (ModuleName) +import Distribution.Text (display) +import Distribution.Verbosity (Verbosity, silent, deafening) + +import Control.Applicative ((<$>)) +import Control.Monad +import Control.Exception (catch, PatternMatchFail(..)) +import Data.List +import Data.Maybe +import Data.Monoid +import Data.IORef +import System.Environment +import System.Directory +import System.FilePath +import System.Exit +import System.IO +import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO) +import Text.Printf +import Common + +--- \ / These types MUST be in sync with the copies in lib:ghc-mod +data GmComponentName = GmSetupHsName + | GmLibName + | GmExeName String + | GmTestName String + | GmBenchName String + deriving (Eq, Ord, Read, Show) +data GmCabalHelperResponse + = GmCabalHelperStrings [(GmComponentName, [String])] + | GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [ModuleName])] + | GmCabalHelperLbi String + deriving (Read, Show) +--- ^ These types MUST be in sync with the copies in ../Types.hs + + +-- MUST be compatible to the one in GHC +newtype ModuleName = ModuleName String + deriving (Eq, Ord, Read, Show) + +usage = do + prog <- getProgName + hPutStr stderr $ align "(" "|" ("Usage: " ++ prog ++ " " ++ usageMsg) + where + usageMsg = "" + ++"DIST_DIR ( version\n" + ++" | print-lbi\n" + ++" | write-autogen-files\n" + ++" | ghc-options [--with-inplace]\n" + ++" | ghc-src-options [--with-inplace]\n" + ++" | ghc-pkg-options [--with-inplace]\n" + ++" | entrypoints\n" + ++" | source-dirs\n" + ++" ) ...\n" + +commands :: [String] +commands = [ "print-bli" + , "write-autogen-files" + , "component-from-file" + , "ghc-options" + , "ghc-src-options" + , "ghc-pkg-options" + , "entrypoints" + , "source-dirs"] + +main :: IO () +main = do + args <- getArgs + + distdir:args' <- case args of + [] -> usage >> exitFailure + _ -> return args + + ddexists <- doesDirectoryExist distdir + when (not ddexists) $ do + errMsg $ "distdir '"++distdir++"' does not exist" + exitFailure + + v <- maybe silent (const deafening) <$> lookupEnv "GHC_MOD_DEBUG" + lbi <- unsafeInterleaveIO $ getPersistBuildConfig distdir + let pd = localPkgDescr lbi + + let + -- a =<< b $$ c == (a =<< b) $$ c + -- a <$$> b $$ c == a <$$> (b $$ c) + infixr 2 $$ + ($$) = ($) + infixr 1 <$$> + (<$$>) = (<$>) + + collectCmdOptions :: [String] -> [[String]] + collectCmdOptions = + reverse . map reverse . foldl f [] . dropWhile isOpt + where + isOpt = ("--" `isPrefixOf`) + f [] x = [[x]] + f (a:as) x + | isOpt x = (x:a):as + | otherwise = [x]:(a:as) + + let cmds = collectCmdOptions args' + + if any (["version"] `isPrefixOf`) cmds + then do + putStrLn $ + printf "using version %s of the Cabal library" (display cabalVersion) + exitSuccess + else return () + + print =<< flip mapM cmds $$ \cmd -> do + case cmd of + "write-autogen-files":[] -> do + let pd = localPkgDescr lbi + -- calls writeAutogenFiles + initialBuildSteps distdir pd lbi v + return Nothing + + "ghc-options":flags -> + Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ + \c clbi bi -> let + outdir = componentOutDir lbi c + (clbi', adopts) = case flags of + ["--with-inplace"] -> (clbi, mempty) + [] -> removeInplaceDeps pd clbi + opts = componentGhcOptions v lbi bi clbi' outdir + in + renderGhcOptions (compiler lbi) $ opts `mappend` adopts + + "ghc-src-options":flags -> + Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ + \c clbi bi -> let + outdir = componentOutDir lbi c + (clbi', adopts) = case flags of + ["--with-inplace"] -> (clbi, mempty) + [] -> removeInplaceDeps pd clbi + opts = componentGhcOptions v lbi bi clbi' outdir + comp = compiler lbi + + opts' = mempty { + -- Not really needed but "unexpected package db stack: []" + ghcOptPackageDBs = [GlobalPackageDB], + ghcOptCppOptions = ghcOptCppOptions opts, + ghcOptCppIncludePath = ghcOptCppIncludePath opts, + ghcOptCppIncludes = ghcOptCppIncludes opts, + ghcOptFfiIncludes = ghcOptFfiIncludes opts, + ghcOptSourcePathClear = ghcOptSourcePathClear opts, + ghcOptSourcePath = ghcOptSourcePath opts + } + in + renderGhcOptions comp $ opts `mappend` adopts + + "ghc-pkg-options":flags -> + Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ + \c clbi bi -> let + comp = compiler lbi + outdir = componentOutDir lbi c + (clbi', adopts) = case flags of + ["--with-inplace"] -> (clbi, mempty) + [] -> removeInplaceDeps pd clbi + opts = componentGhcOptions v lbi bi clbi' outdir + + opts' = mempty { + ghcOptPackageDBs = ghcOptPackageDBs opts, + ghcOptPackages = ghcOptPackages opts, + ghcOptHideAllPackages = ghcOptHideAllPackages opts + } + in + renderGhcOptions (compiler lbi) $ opts' `mappend` adopts + + "entrypoints":[] -> do + eps <- componentsMap lbi v distdir $ \c clbi bi -> + componentEntrypoints c + -- MUST append Setup component at the end otherwise CabalHelper gets + -- confused + let eps' = eps ++ [(GmSetupHsName, Right [ModuleName "Setup"])] + return $ Just $ GmCabalHelperEntrypoints eps' + + "source-dirs":[] -> + Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ + \c clbi bi -> hsSourceDirs bi + + "print-lbi":[] -> + return $ Just $ GmCabalHelperLbi $ show lbi + + cmd:_ | not (cmd `elem` commands) -> + errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure + _ -> + errMsg "Invalid usage!" >> usage >> exitFailure + + +getLibrary :: PackageDescription -> Library +getLibrary pd = unsafePerformIO $ do + lr <- newIORef (error "libraryMap: empty IORef") + withLib pd (writeIORef lr) + readIORef lr + +componentsMap :: LocalBuildInfo + -> Verbosity + -> FilePath + -> ( Component + -> ComponentLocalBuildInfo + -> BuildInfo + -> a) + -> IO [(GmComponentName, a)] +componentsMap lbi v distdir f = do + let pd = localPkgDescr lbi + + lr <- newIORef [] + + withComponentsLBI pd lbi $ \c clbi -> do + let bi = componentBuildInfo c + name = componentNameFromComponent c + + l' <- readIORef lr + writeIORef lr $ (componentNameToGm name, f c clbi bi):l' + reverse <$> readIORef lr + +componentNameToGm CLibName = GmLibName +componentNameToGm (CExeName n) = GmExeName n +componentNameToGm (CTestName n) = GmTestName n +componentNameToGm (CBenchName n) = GmBenchName n + +componentNameFromComponent (CLib Library {}) = CLibName +componentNameFromComponent (CExe Executable {..}) = CExeName exeName +componentNameFromComponent (CTest TestSuite {..}) = CTestName testName +componentNameFromComponent (CBench Benchmark {..}) = CBenchName benchmarkName + +componentOutDir lbi (CLib Library {..})= buildDir lbi +componentOutDir lbi (CExe Executable {..})= exeOutDir lbi exeName +componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteExeV10 _ _, ..}) = + exeOutDir lbi testName +componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteLibV09 _ _, ..}) = + exeOutDir lbi (testName ++ "Stub") +componentOutDir lbi (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ _, ..})= + exeOutDir lbi benchmarkName + +gmModuleName :: C.ModuleName -> ModuleName +gmModuleName = ModuleName . intercalate "." . components + +componentEntrypoints :: Component -> Either FilePath [ModuleName] +componentEntrypoints (CLib Library {..}) + = Right $ map gmModuleName exposedModules +componentEntrypoints (CExe Executable {..}) + = Left modulePath +componentEntrypoints (CTest TestSuite { testInterface = TestSuiteExeV10 _ fp }) + = Left fp +componentEntrypoints (CTest TestSuite { testInterface = TestSuiteLibV09 _ mn }) + = Right [gmModuleName mn] +componentEntrypoints (CTest TestSuite {}) + = Right [] +componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ fp}) + = Left fp +componentEntrypoints (CBench Benchmark {}) + = Left [] + +exeOutDir :: LocalBuildInfo -> String -> FilePath +exeOutDir lbi exeName = + ----- Copied from Distribution/Simple/GHC.hs:buildOrReplExe + -- exeNameReal, the name that GHC really uses (with .exe on Windows) + let exeNameReal = exeName <.> + (if takeExtension exeName /= ('.':exeExtension) + then exeExtension + else "") + + targetDir = (buildDir lbi) exeName + in targetDir + + +removeInplaceDeps :: PackageDescription + -> ComponentLocalBuildInfo + -> (ComponentLocalBuildInfo, GhcOptions) +removeInplaceDeps pd clbi = let + (ideps, deps) = partition isInplaceDep (componentPackageDeps clbi) + hasIdeps = not $ null ideps + clbi' = clbi { componentPackageDeps = deps } + lib = getLibrary pd + src_dirs = hsSourceDirs (libBuildInfo lib) + adopts = mempty { + ghcOptSourcePath = +#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22 + toNubListR src_dirs +#else + src_dirs +#endif + + } + + in (clbi', if hasIdeps then adopts else mempty) + + where + isInplaceDep :: (InstalledPackageId, PackageId) -> Bool + isInplaceDep (ipid, pid) = inplacePackageId pid == ipid diff --git a/cabal-helper/Wrapper.hs b/cabal-helper/Wrapper.hs new file mode 100644 index 0000000..40c6315 --- /dev/null +++ b/cabal-helper/Wrapper.hs @@ -0,0 +1,258 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE TemplateHaskell, OverloadedStrings, RecordWildCards #-} +module Main where + +import Control.Applicative +import Control.Arrow +import Control.Monad +import Control.Monad.Trans.Maybe +import Data.Char +import Data.List +import Data.Maybe +import Data.String +import Data.Version +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Text.Printf +import Text.ParserCombinators.ReadP +import System.Environment +import System.Directory +import System.FilePath +import System.Process +import System.Exit +import System.IO + +import Distribution.System (buildPlatform) +import Distribution.Text (display) + +import NotCPP.Declarations + +import Paths_ghc_mod +import Common +import Utils + +ifD [d| getExecutablePath = getProgName |] + +usage :: IO () +usage = do + prog <- getProgName + hPutStr stderr $ align "(" "|" ("Usage: " ++ prog ++ " " ++ usageMsg) + where + usageMsg = "\ +\( print-appdatadir\n\ +\| print-build-platform\n\ +\| DIST_DIR [CABAL_HELPER_ARGS...]\n\ +\)\n" + +main :: IO () +main = do + args <- getArgs + case args of + "print-appdatadir":[] -> putStrLn =<< appDataDir + "print-build-platform":[] -> putStrLn $ display buildPlatform + distdir:_ -> do + cfgf <- canonicalizePath (distdir "setup-config") + mhdr <- (parseHeader =<<) . listToMaybe . BS8.lines <$> BS.readFile cfgf + case mhdr of + Nothing -> error $ printf "\ +\Could not read Cabal's persistent setup configuration header\n\ +\- Check first line of: %s\n\ +\- Maybe try: $ cabal configure" cfgf + + Just Header {..} -> do + eexe <- compileHelper hdrCabalVersion + case eexe of + Left e -> exitWith e + Right exe -> do + (_,_,_,h) <- createProcess $ proc exe args + exitWith =<< waitForProcess h + + _ -> usage + +appDataDir :: IO FilePath +appDataDir = ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" + +tryFindSrcDirInGhcModTree :: IO (Maybe FilePath) +tryFindSrcDirInGhcModTree = do + dir <- (!!4) . iterate takeDirectory <$> getExecutablePath + exists <- doesFileExist $ dir "ghc-mod.cabal" + src_exists <- doesFileExist $ dir "cabal-helper/Main.hs" + if exists && src_exists + then return $ Just (dir "cabal-helper") + else return Nothing + +tryFindRealSrcDir :: IO (Maybe FilePath) +tryFindRealSrcDir = do + datadir <- getDataDir + exists <- doesFileExist $ datadir "cabal-helper/Main.hs" + return $ if exists + then Just $ datadir "cabal-helper" + else Nothing + +findCabalHelperSourceDir :: IO FilePath +findCabalHelperSourceDir = do + msrcdir <- runMaybeT $ MaybeT tryFindSrcDirInGhcModTree + <|> MaybeT tryFindRealSrcDir + case msrcdir of + Nothing -> getDataDir >>= errorNoMain + Just datadir -> return datadir + +compileHelper :: Version -> IO (Either ExitCode FilePath) +compileHelper cabalVer = do + chdir <- findCabalHelperSourceDir + mver <- find (sameMajorVersion cabalVer) <$> listCabalVersions + couldBeSrcDir <- takeDirectory <$> getDataDir + + case mver of + Nothing -> do + let cabalFile = couldBeSrcDir "Cabal.cabal" + cabal <- doesFileExist cabalFile + if cabal + then do + ver <- cabalFileVersion <$> readFile cabalFile + compile $ Compile chdir (Just couldBeSrcDir) ver [] + else errorNoCabal cabalVer + Just ver -> + compile $ Compile chdir Nothing ver [cabalPkgId ver] + where + cabalPkgId v = "Cabal-" ++ showVersion v + +errorNoCabal :: Version -> a +errorNoCabal cabalVer = error $ printf "\ +\No appropriate Cabal package found, wanted version %s.\n\ +\- Check output of: $ ghc-pkg list Cabal\n\ +\- Maybe try: $ cabal install Cabal --constraint 'Cabal == %s.*'" sver mjver + where + sver = showVersion cabalVer + mjver = showVersion $ majorVer cabalVer + +errorNoMain :: FilePath -> a +errorNoMain datadir = error $ printf "\ +\Could not find $datadir/cabal-helper/Main.hs!\n\ +\\n\ +\If you are a developer you can use the environment variable `ghc_mod_datadir'\n\ +\to override $datadir[1], `$ export ghc_mod_datadir=$PWD' will work in the\n\ +\ghc-mod tree.\n\ +\[1]: %s\n\ +\\n\ +\If you don't know what I'm talking about something went wrong with your\n\ +\installation. Please report this problem here:\n\ +\ https://github.com/kazu-yamamoto/ghc-mod/issues" datadir + +data Compile = Compile { + cabalHelperSourceDir :: FilePath, + cabalSourceDir :: Maybe FilePath, + cabalVersion :: Version, + packageDeps :: [String] + } + +compile :: Compile -> IO (Either ExitCode FilePath) +compile Compile {..} = do + outdir <- appDataDir + createDirectoryIfMissing True outdir + + let exe = outdir "cabal-helper-" ++ showVersion (majorVer cabalVersion) + + recompile <- + case cabalSourceDir of + Nothing -> do + tsrcs <- timeHsFiles cabalHelperSourceDir + texe <- timeMaybe exe + return $ any ((texe <) . Just) tsrcs + Just _ -> return True -- let ghc do the difficult recomp checking + + let Version (mj:mi:_) _ = cabalVersion + let ghc_opts = + concat [ + [ "-outputdir", outdir + , "-o", exe + , "-optP-DCABAL_MAJOR=" ++ show mj + , "-optP-DCABAL_MINOR=" ++ show mi + ], + map ("-i"++) $ cabalHelperSourceDir:maybeToList cabalSourceDir, + concatMap (\p -> ["-package", p]) packageDeps, + [ "--make", cabalHelperSourceDir "Main.hs" ] + ] + + if recompile + then do + (_, _, _, h) <- createProcess + (proc "ghc" ghc_opts) { std_out = UseHandle stderr } + rv <- waitForProcess h + return $ case rv of + ExitSuccess -> Right exe + e@(ExitFailure _) -> Left e + else return $ Right exe + +timeHsFiles :: FilePath -> IO [TimedFile] +timeHsFiles dir = do + fs <- map (dir) <$> getDirectoryContents dir + mapM timeFile =<< filterM isHsFile fs + where + isHsFile f = do + exists <- doesFileExist f + return $ exists && ".hs" `isSuffixOf` f + + + +-- TODO: Include sandbox? Probably only relevant for build-type:custom projects. +listCabalVersions :: IO [Version] +listCabalVersions = do + catMaybes . map (fmap snd . parsePkgId . fromString) . words + <$> readProcess "ghc-pkg" ["list", "--simple-output", "Cabal"] "" + +data Header = Header { hdrCabalVersion :: Version + , hdrCompilerVersion :: Version + } + +-- | Find @version: XXX@ delcaration in a cabal file +cabalFileVersion :: String -> Version +cabalFileVersion cabalFile = do + fromJust $ parseVer . extract <$> find ("version" `isPrefixOf`) ls + where + ls = map (map toLower) $ lines cabalFile + extract = dropWhile (/=':') >>> dropWhile isSpace >>> takeWhile (not . isSpace) + +parseHeader :: ByteString -> Maybe Header +parseHeader header = case BS8.words header of + ["Saved", "package", "config", "for", _pkgId , + "written", "by", cabalId, + "using", compId] + -> liftM2 Header (ver cabalId) (ver compId) + _ -> error "parsing setup-config header failed" + where + ver i = snd <$> parsePkgId i + +parsePkgId :: ByteString -> Maybe (ByteString, Version) +parsePkgId bs = + case BS8.split '-' bs of + [pkg, vers] -> Just (pkg, parseVer $ BS8.unpack vers) + _ -> Nothing + +parseVer :: String -> Version +parseVer vers = runReadP parseVersion vers + +majorVer :: Version -> Version +majorVer (Version b _) = Version (take 2 b) [] + +sameMajorVersion :: Version -> Version -> Bool +sameMajorVersion a b = majorVer a == majorVer b + +runReadP :: ReadP t -> String -> t +runReadP p i = let (a,""):[] = filter ((=="") . snd) $ readP_to_S p i in a diff --git a/ghc-mod.cabal b/ghc-mod.cabal index bd7c082..30be14b 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -186,20 +186,25 @@ Executable ghc-modi , ghc , ghc-mod -Executable cabal-helper +Executable cabal-helper-wrapper Default-Language: Haskell2010 - Main-Is: GHCModCabal.hs + Other-Extensions: TemplateHaskell + Main-Is: Wrapper.hs + Other-Modules: Paths_ghc_mod GHC-Options: -Wall - HS-Source-Dirs: src + HS-Source-Dirs: cabal-helper, . X-Install-Target: $libexecdir Build-Depends: base >= 4.0 && < 5 , bytestring , binary + , containers + , Cabal >= 1.16 , directory - if flag(cabal-122) - Build-Depends: Cabal >= 1.22 - else - Buildable: False + , filepath + , process + , transformers + , template-haskell + , time Test-Suite doctest Type: exitcode-stdio-1.0 diff --git a/src/GHCModCabal.hs b/src/GHCModCabal.hs deleted file mode 100644 index 5aec6d9..0000000 --- a/src/GHCModCabal.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Main where - -import Control.Applicative - -import Distribution.Simple.Utils (cabalVersion) -import Distribution.Simple.Configure -import Distribution.Text ( display ) -import System.Environment -import System.Directory - -main :: IO () -main = do - args <- getArgs - case args of - "version":[] -> do - putStrLn $ "using version " ++ display cabalVersion ++ " of the Cabal library" - "print-setup-config":args' -> do - mfile <- findFile ["dist"] "setup-config" - - let file = case mfile of - Just f -> f - Nothing -> let !(f:[]) = args' in f - - putStrLn =<< show <$> getConfigStateFile file - - cmd:_ -> error $ "Unknown command: " ++ cmd - [] -> error "No command given" From 7438539ca59471624471d68b9941ab9993f4f129 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 3 Mar 2015 20:28:34 +0100 Subject: [PATCH 018/207] Change primary license to AGPL-3 --- COPYING.AGPL3 | 661 +++++++++++++++++++++++ LICENSE => COPYING.BSD3 | 0 Language/Haskell/GhcMod/Error.hs | 15 + Language/Haskell/GhcMod/Logging.hs | 15 + Language/Haskell/GhcMod/Monad.hs | 15 + Language/Haskell/GhcMod/Monad/Types.hs | 16 + Language/Haskell/GhcMod/PathsAndFiles.hs | 16 + Language/Haskell/GhcMod/Target.hs | 15 + Language/Haskell/GhcMod/Utils.hs | 16 + NotCPP/Declarations.hs | 16 + ghc-mod.cabal | 4 +- 11 files changed, 787 insertions(+), 2 deletions(-) create mode 100644 COPYING.AGPL3 rename LICENSE => COPYING.BSD3 (100%) diff --git a/COPYING.AGPL3 b/COPYING.AGPL3 new file mode 100644 index 0000000..dba13ed --- /dev/null +++ b/COPYING.AGPL3 @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + + A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + + The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + + An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing under +this license. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU Affero General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Remote Network Interaction; Use with the GNU General Public License. + + Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your version +supports such interaction) an opportunity to receive the Corresponding +Source of your version by providing access to the Corresponding Source +from a network server at no charge, through some standard or customary +means of facilitating copying of software. This Corresponding Source +shall include the Corresponding Source for any work covered by version 3 +of the GNU General Public License that is incorporated pursuant to the +following paragraph. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the work with which it is combined will remain governed by version +3 of the GNU General Public License. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU Affero General Public License from time to time. Such new versions +will be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU Affero General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU Affero General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU Affero General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for the +specific requirements. + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU AGPL, see +. diff --git a/LICENSE b/COPYING.BSD3 similarity index 100% rename from LICENSE rename to COPYING.BSD3 diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index a05b1e1..23c52a3 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -1,4 +1,19 @@ {-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-} +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . module Language.Haskell.GhcMod.Error ( GhcModError(..) , GMConfigStateFileError(..) diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 62a8412..e377d06 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -1,4 +1,19 @@ module Language.Haskell.GhcMod.Logging where +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 6be1b23..8c36681 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -1,4 +1,19 @@ {-# LANGUAGE CPP, RecordWildCards #-} +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . module Language.Haskell.GhcMod.Monad ( -- * Monad Types GhcModT diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 0cd2494..0c454bc 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -1,3 +1,19 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} {-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-} diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 68c75aa..e569360 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -1,4 +1,20 @@ {-# LANGUAGE BangPatterns, TupleSections #-} +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + module Language.Haskell.GhcMod.PathsAndFiles where import Config (cProjectVersion) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 51d64e4..75d3d3b 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -2,6 +2,21 @@ module Language.Haskell.GhcMod.Target ( setTargetFiles ) where +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . import Control.Applicative ((<$>)) import Control.Monad (forM, void, (>=>)) diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 1f1f63d..7574bbb 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -1,3 +1,19 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + {-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.Utils where diff --git a/NotCPP/Declarations.hs b/NotCPP/Declarations.hs index 7ae4188..02fb48f 100644 --- a/NotCPP/Declarations.hs +++ b/NotCPP/Declarations.hs @@ -1,3 +1,19 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE CPP #-} -- Using CPP so you don't have to :) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 30be14b..77e2217 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -4,8 +4,8 @@ Author: Kazu Yamamoto Daniel Gröber Alejandro Serrano Maintainer: Kazu Yamamoto -License: BSD3 -License-File: LICENSE +License: AGPL-3 +License-Files: COPYING.BSD3 COPYING.AGPL3 Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ Synopsis: Happy Haskell Programming Description: The ghc-mod command is a backend command to enrich From 82bb0090c0b7f0d453909dba9d960707bf86cfc8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 3 Mar 2015 21:12:43 +0100 Subject: [PATCH 019/207] Refactoring to use cabal-helper-wrapper This turned out to be quite involved but save for this huge commit it's actually quite awesome and squashes quite a few bugs and nasty problems (hopefully). Most importantly we now have native cabal component support without the user having to do anything to get it! To do this we traverse imports starting from each component's entrypoints (library modules or Main source file for executables) and use this information to find which component's options each module will build with. Under the assumption that these modules have to build with every component they're used in we can now just pick one. Quite a few internal assumptions have been invalidated by this change. Most importantly the runGhcModT* family of cuntions now change the current working directory to `cradleRootDir`. --- Language/Haskell/GhcMod.hs | 8 +- Language/Haskell/GhcMod/Browse.hs | 70 +-- Language/Haskell/GhcMod/CabalApi.hs | 144 ------ Language/Haskell/GhcMod/CabalConfig.hs | 35 -- .../Haskell/GhcMod/CabalConfig/Cabal16.hs | 45 -- .../Haskell/GhcMod/CabalConfig/Cabal18.hs | 58 --- .../Haskell/GhcMod/CabalConfig/Cabal21.hs | 73 --- .../Haskell/GhcMod/CabalConfig/Cabal22.hs | 107 ----- .../Haskell/GhcMod/CabalConfig/Extract.hs | 223 --------- Language/Haskell/GhcMod/CabalConfig/Ghc710.hs | 49 -- Language/Haskell/GhcMod/CabalHelper.hs | 104 +++++ Language/Haskell/GhcMod/CaseSplit.hs | 73 +-- Language/Haskell/GhcMod/Check.hs | 30 +- Language/Haskell/GhcMod/Convert.hs | 4 +- Language/Haskell/GhcMod/Cradle.hs | 74 +-- Language/Haskell/GhcMod/Debug.hs | 85 ++-- Language/Haskell/GhcMod/Doc.hs | 12 +- Language/Haskell/GhcMod/DynFlags.hs | 32 +- Language/Haskell/GhcMod/Error.hs | 163 ++++--- Language/Haskell/GhcMod/FillSig.hs | 53 ++- Language/Haskell/GhcMod/Find.hs | 14 +- Language/Haskell/GhcMod/GHCChoice.hs | 23 - Language/Haskell/GhcMod/Gap.hs | 109 +---- Language/Haskell/GhcMod/GhcPkg.hs | 31 -- Language/Haskell/GhcMod/HomeModuleGraph.hs | 270 +++++++++++ Language/Haskell/GhcMod/Info.hs | 44 +- Language/Haskell/GhcMod/Internal.hs | 19 - Language/Haskell/GhcMod/Logger.hs | 116 ++--- Language/Haskell/GhcMod/Logging.hs | 48 +- Language/Haskell/GhcMod/Modules.hs | 7 +- Language/Haskell/GhcMod/Monad.hs | 238 ++-------- Language/Haskell/GhcMod/Monad/Types.hs | 424 ++++++++++++------ Language/Haskell/GhcMod/PathsAndFiles.hs | 106 +++-- Language/Haskell/GhcMod/PkgDoc.hs | 4 +- Language/Haskell/GhcMod/Pretty.hs | 64 +++ Language/Haskell/GhcMod/SrcUtils.hs | 23 +- Language/Haskell/GhcMod/Target.hs | 333 ++++++++++++-- Language/Haskell/GhcMod/Types.hs | 186 +++++--- Language/Haskell/GhcMod/Utils.hs | 140 +++--- Language/Haskell/GhcMod/World.hs | 46 +- Utils.hs | 36 ++ ghc-mod.cabal | 63 ++- src/GHCMod.hs | 9 +- 43 files changed, 1951 insertions(+), 1844 deletions(-) delete mode 100644 Language/Haskell/GhcMod/CabalApi.hs delete mode 100644 Language/Haskell/GhcMod/CabalConfig.hs delete mode 100644 Language/Haskell/GhcMod/CabalConfig/Cabal16.hs delete mode 100644 Language/Haskell/GhcMod/CabalConfig/Cabal18.hs delete mode 100644 Language/Haskell/GhcMod/CabalConfig/Cabal21.hs delete mode 100644 Language/Haskell/GhcMod/CabalConfig/Cabal22.hs delete mode 100644 Language/Haskell/GhcMod/CabalConfig/Extract.hs delete mode 100644 Language/Haskell/GhcMod/CabalConfig/Ghc710.hs create mode 100644 Language/Haskell/GhcMod/CabalHelper.hs delete mode 100644 Language/Haskell/GhcMod/GHCChoice.hs create mode 100644 Language/Haskell/GhcMod/HomeModuleGraph.hs create mode 100644 Language/Haskell/GhcMod/Pretty.hs create mode 100644 Utils.hs diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index b356efa..b9a1976 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -9,6 +9,11 @@ module Language.Haskell.GhcMod ( , LineSeparator(..) , OutputStyle(..) , defaultOptions + -- * Logging + , GmLogLevel + , increaseLogLevel + , gmSetLogLevel + , gmLog -- * Types , ModuleString , Expression @@ -61,7 +66,8 @@ import Language.Haskell.GhcMod.Flag import Language.Haskell.GhcMod.Info import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lint -import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Modules +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.Types diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 5efe157..55a8afb 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -4,52 +4,54 @@ module Language.Haskell.GhcMod.Browse ( import Control.Applicative ((<$>)) import Control.Exception (SomeException(..)) -import Data.Char (isAlpha) -import Data.List (sort) -import Data.Maybe (catMaybes) -import Exception (ghandle) -import FastString (mkFastString) -import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon) +import Data.Char +import Data.List +import Data.Maybe +import FastString +import GHC import qualified GHC as G import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified) import Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Monad (GhcModT, options) -import Language.Haskell.GhcMod.Target (setTargetFiles) +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Name (getOccString) -import Outputable (ppr, Outputable) +import Outputable import TyCon (isAlgTyCon) import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) +import Exception (ExceptionMonad, ghandle) ---------------------------------------------------------------- -- | Getting functions, classes, etc from a module. -- If 'detailed' is 'True', their types are also obtained. -- If 'operators' is 'True', operators are also returned. -browse :: IOish m +browse :: forall m. IOish m => ModuleString -- ^ A module name. (e.g. \"Data.List\") -> GhcModT m String -browse pkgmdl = convert' . sort =<< (listExports =<< getModule) +browse pkgmdl = do + convert' . sort =<< go where + -- TODO: Add API to Gm.Target to check if module is home module without + -- bringing up a GHC session as well then this can be made a lot cleaner + go = ghandle (\(SomeException _) -> return []) $ do + goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule) + + goPkgModule = do + opt <- options + runGmPkgGhc $ + processExports opt =<< tryModuleInfo =<< G.findModule mdlname mpkgid + + goHomeModule = runGmLoadedT [Right mdlname] $ do + opt <- options + processExports opt =<< tryModuleInfo =<< G.findModule mdlname Nothing + + tryModuleInfo m = fromJust <$> G.getModuleInfo m + (mpkg,mdl) = splitPkgMdl pkgmdl mdlname = G.mkModuleName mdl mpkgid = mkFastString <$> mpkg - listExports Nothing = return [] - listExports (Just mdinfo) = processExports mdinfo - -- findModule works only for package modules, moreover, - -- you cannot load a package module. On the other hand, - -- to browse a local module you need to load it first. - -- If CmdLineError is signalled, we assume the user - -- tried browsing a local module. - getModule = browsePackageModule `G.gcatch` fallback `G.gcatch` handler - browsePackageModule = G.findModule mdlname mpkgid >>= G.getModuleInfo - browseLocalModule = ghandle handler $ do - setTargetFiles [mdl] - G.findModule mdlname Nothing >>= G.getModuleInfo - fallback (CmdLineError _) = browseLocalModule - fallback _ = return Nothing - handler (SomeException _) = return Nothing + -- | -- -- >>> splitPkgMdl "base:Prelude" @@ -71,22 +73,23 @@ isNotOp :: String -> Bool isNotOp (h:_) = isAlpha h || (h == '_') isNotOp _ = error "isNotOp" -processExports :: IOish m => ModuleInfo -> GhcModT m [String] -processExports minfo = do - opt <- options +processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m) + => Options -> ModuleInfo -> m [String] +processExports opt minfo = do let removeOps | operators opt = id | otherwise = filter (isNotOp . getOccString) mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo -showExport :: IOish m => Options -> ModuleInfo -> Name -> GhcModT m String +showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m) + => Options -> ModuleInfo -> Name -> m String showExport opt minfo e = do mtype' <- mtype return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] where mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt - mtype :: IOish m => GhcModT m (Maybe String) + mtype :: m (Maybe String) mtype | detailed opt = do tyInfo <- G.modInfoLookupName minfo e @@ -101,8 +104,9 @@ showExport opt minfo e = do | null nm = error "formatOp" | isNotOp nm = nm | otherwise = "(" ++ nm ++ ")" - inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing) - inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm + inOtherModule :: Name -> m (Maybe TyThing) + inOtherModule nm = do + G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm justIf :: a -> Bool -> Maybe a justIf x True = Just x justIf _ False = Nothing diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs deleted file mode 100644 index 063a1fa..0000000 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} - -module Language.Haskell.GhcMod.CabalApi ( - getCompilerOptions - , parseCabalFile - , cabalAllBuildInfo - , cabalSourceDirs - , cabalConfigDependencies - ) where - -import Language.Haskell.GhcMod.CabalConfig -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, mkGHCCompilerId) -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Logging - -import MonadUtils (liftIO) -import Control.Applicative ((<$>)) -import qualified Control.Exception as E -import Data.Maybe (maybeToList) -import Data.Set (fromList, toList) -import Distribution.Package (PackageName(PackageName)) -import qualified Distribution.Package as C -import Distribution.PackageDescription (PackageDescription, BuildInfo) -import qualified Distribution.PackageDescription as P -import Distribution.PackageDescription.Configuration (finalizePackageDescription) -import Distribution.PackageDescription.Parse (readPackageDescription) -import Distribution.Simple.Program as C (ghcProgram) -import Distribution.Simple.Program.Types (programName, programFindVersion) -import Distribution.System (buildPlatform) -import Distribution.Text (display) -import Distribution.Verbosity (silent) -import Distribution.Version (Version) -import System.Directory (doesFileExist) -import System.FilePath (()) ----------------------------------------------------------------- - --- | Getting necessary 'CompilerOptions' from three information sources. -getCompilerOptions :: (IOish m, GmError m, GmLog m) - => [GHCOption] - -> Cradle - -> CabalConfig - -> PackageDescription - -> m CompilerOptions -getCompilerOptions ghcopts cradle config pkgDesc = do - gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos - let depPkgs = cabalConfigDependencies config (C.packageId pkgDesc) - return $ CompilerOptions gopts idirs depPkgs - where - wdir = cradleCurrentDir cradle - rdir = cradleRootDir cradle - buildInfos = cabalAllBuildInfo pkgDesc - idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos - ----------------------------------------------------------------- --- Include directories for modules - -cabalBuildDirs :: [FilePath] -cabalBuildDirs = ["dist/build", "dist/build/autogen"] - -includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath] -includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir]) - where - extdirs = map expand $ dirs ++ cabalBuildDirs - expand "." = cdir - expand subdir = cdir subdir - ----------------------------------------------------------------- - --- | Parse a cabal file and return a 'PackageDescription'. -parseCabalFile :: (IOish m, GmError m, GmLog m) - => CabalConfig - -> FilePath - -> m PackageDescription -parseCabalFile config file = do - cid <- mkGHCCompilerId <$> liftIO getGHCVersion - epgd <- liftIO $ readPackageDescription silent file - flags <- cabalConfigFlags config - case toPkgDesc cid flags epgd of - Left deps -> fail $ show deps ++ " are not installed" - Right (pd,_) -> if nullPkg pd - then fail $ file ++ " is broken" - else return pd - where - toPkgDesc cid flags = - finalizePackageDescription flags (const True) buildPlatform cid [] - nullPkg pd = name == "" - where - PackageName name = C.pkgName (P.package pd) - -getGHCVersion :: IO Version -getGHCVersion = do - mv <- programFindVersion C.ghcProgram silent (programName C.ghcProgram) - case mv of - -- TODO: MonadError it up - Nothing -> E.throwIO $ userError "ghc not found" - Just v -> return v - ----------------------------------------------------------------- - -getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption] -getGHCOptions ghcopts cradle rdir binfo = do - cabalCpp <- cabalCppOptions rdir - let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp - return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps - where - pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle - lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo - libDirs = map ("-L" ++) $ P.extraLibDirs binfo - exts = map (("-X" ++) . display) $ P.usedExtensions binfo - libs = map ("-l" ++) $ P.extraLibs binfo - -cabalCppOptions :: FilePath -> IO [String] -cabalCppOptions dir = do - exist <- doesFileExist cabalMacro - return $ if exist then - ["-include", cabalMacro] - else - [] - where - cabalMacro = dir "dist/build/autogen/cabal_macros.h" - ----------------------------------------------------------------- - --- | Extracting all 'BuildInfo' for libraries, executables, and tests. -cabalAllBuildInfo :: PackageDescription -> [BuildInfo] -cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI - where - libBI = map P.libBuildInfo $ maybeToList $ P.library pd - execBI = map P.buildInfo $ P.executables pd - testBI = map P.testBuildInfo $ P.testSuites pd - benchBI = benchmarkBuildInfo pd - ----------------------------------------------------------------- - --- | Extracting include directories for modules. -cabalSourceDirs :: [BuildInfo] -> [IncludeDir] -cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis - ----------------------------------------------------------------- - -uniqueAndSort :: [String] -> [String] -uniqueAndSort = toList . fromList diff --git a/Language/Haskell/GhcMod/CabalConfig.hs b/Language/Haskell/GhcMod/CabalConfig.hs deleted file mode 100644 index 2d9d9da..0000000 --- a/Language/Haskell/GhcMod/CabalConfig.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | This module abstracts extracting information from Cabal's on-disk --- 'LocalBuildInfo' (@dist/setup-config@) for different version combinations of --- Cabal and GHC. -module Language.Haskell.GhcMod.CabalConfig ( - CabalConfig - , cabalGetConfig - , cabalConfigDependencies - , cabalConfigFlags - ) where - -import Distribution.Package (PackageIdentifier) -import Distribution.PackageDescription (FlagAssignment) - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Error - -import Language.Haskell.GhcMod.CabalConfig.Extract - -cabalGetConfig :: (IOish m, GmError m) => Cradle -> m CabalConfig -cabalGetConfig = getConfig - --- | Get list of 'Package's needed by all components of the current package -cabalConfigDependencies :: CabalConfig -> PackageIdentifier -> [Package] -cabalConfigDependencies config thisPkg = - configDependencies thisPkg config - - --- | Get the flag assignment from the local build info of the given cradle -cabalConfigFlags :: (IOish m, GmError m) => CabalConfig -> m FlagAssignment -cabalConfigFlags config = do - case configFlags config of - Right x -> return x - Left msg -> throwError (GMECabalFlags (GMEString msg)) diff --git a/Language/Haskell/GhcMod/CabalConfig/Cabal16.hs b/Language/Haskell/GhcMod/CabalConfig/Cabal16.hs deleted file mode 100644 index be9e7cf..0000000 --- a/Language/Haskell/GhcMod/CabalConfig/Cabal16.hs +++ /dev/null @@ -1,45 +0,0 @@ --- Copyright : Isaac Jones 2003-2004 -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - - --- | ComponentLocalBuildInfo for Cabal <= 1.16 -module Language.Haskell.GhcMod.CabalConfig.Cabal16 ( - ComponentLocalBuildInfo - , componentPackageDeps - ) where - -import Distribution.Package (InstalledPackageId, PackageIdentifier) - --- From Cabal <= 1.16 -data ComponentLocalBuildInfo = ComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageIdentifier)] - } - deriving (Read, Show) diff --git a/Language/Haskell/GhcMod/CabalConfig/Cabal18.hs b/Language/Haskell/GhcMod/CabalConfig/Cabal18.hs deleted file mode 100644 index f60366b..0000000 --- a/Language/Haskell/GhcMod/CabalConfig/Cabal18.hs +++ /dev/null @@ -1,58 +0,0 @@ --- Copyright : Isaac Jones 2003-2004 -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - --- | ComponentLocalBuildInfo for Cabal >= 1.18 -module Language.Haskell.GhcMod.CabalConfig.Cabal18 ( - ComponentLocalBuildInfo - , componentPackageDeps - , componentLibraries - ) where - -import Distribution.Package (InstalledPackageId, PackageId) - -data LibraryName = LibraryName String - deriving (Read, Show) - -data ComponentLocalBuildInfo - = LibComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)], - componentLibraries :: [LibraryName] - } - | ExeComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - | TestComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - | BenchComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - deriving (Read, Show) diff --git a/Language/Haskell/GhcMod/CabalConfig/Cabal21.hs b/Language/Haskell/GhcMod/CabalConfig/Cabal21.hs deleted file mode 100644 index bde56bc..0000000 --- a/Language/Haskell/GhcMod/CabalConfig/Cabal21.hs +++ /dev/null @@ -1,73 +0,0 @@ --- Copyright : Isaac Jones 2003-2004 -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - --- | ComponentLocalBuildInfo for Cabal >= 1.21 -module Language.Haskell.GhcMod.CabalConfig.Cabal21 ( - ComponentLocalBuildInfo - , PackageIdentifier(..) - , PackageName(..) - , componentPackageDeps - , componentLibraries - ) where - -import Distribution.Package (InstalledPackageId) -import Data.Version (Version) - -data LibraryName = LibraryName String - deriving (Read, Show) - -newtype PackageName = PackageName { unPackageName :: String } - deriving (Read, Show) - -data PackageIdentifier - = PackageIdentifier { - pkgName :: PackageName, - pkgVersion :: Version - } - deriving (Read, Show) - -type PackageId = PackageIdentifier - -data ComponentLocalBuildInfo - = LibComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)], - componentLibraries :: [LibraryName] - } - | ExeComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - | TestComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - | BenchComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - deriving (Read, Show) diff --git a/Language/Haskell/GhcMod/CabalConfig/Cabal22.hs b/Language/Haskell/GhcMod/CabalConfig/Cabal22.hs deleted file mode 100644 index da6ef88..0000000 --- a/Language/Haskell/GhcMod/CabalConfig/Cabal22.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-binds #-} --- Copyright : Isaac Jones 2003-2004 --- Copyright : (c) The University of Glasgow 2004 --- Copyright : Duncan Coutts 2008 -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - --- | ComponentLocalBuildInfo for Cabal >= 1.22 -module Language.Haskell.GhcMod.CabalConfig.Cabal22 ( - ComponentLocalBuildInfo - , PackageIdentifier(..) - , PackageName(..) - , componentPackageDeps - , componentLibraries - ) where - -import Distribution.Package (InstalledPackageId) -import Data.Version (Version) -import Data.Map (Map) - -data LibraryName = LibraryName String - deriving (Read, Show) - -newtype PackageName = PackageName { unPackageName :: String } - deriving (Read, Show, Ord, Eq) - -data PackageIdentifier - = PackageIdentifier { - pkgName :: PackageName, - pkgVersion :: Version - } - deriving (Read, Show) - -type PackageId = PackageIdentifier - -newtype ModuleName = ModuleName [String] - deriving (Read, Show) - -data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)] - deriving (Read, Show) - -data OriginalModule - = OriginalModule { - originalPackageId :: InstalledPackageId, - originalModuleName :: ModuleName - } - deriving (Read, Show) - -data ExposedModule - = ExposedModule { - exposedName :: ModuleName, - exposedReexport :: Maybe OriginalModule, - exposedSignature :: Maybe OriginalModule -- This field is unused for now. - } - deriving (Read, Show) - -data ComponentLocalBuildInfo - = LibComponentLocalBuildInfo { - -- | Resolved internal and external package dependencies for this component. - -- The 'BuildInfo' specifies a set of build dependencies that must be - -- satisfied in terms of version ranges. This field fixes those dependencies - -- to the specific versions available on this machine for this compiler. - componentPackageDeps :: [(InstalledPackageId, PackageId)], - componentExposedModules :: [ExposedModule], - componentPackageRenaming :: Map PackageName ModuleRenaming, - componentLibraries :: [LibraryName] - } - | ExeComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)], - componentPackageRenaming :: Map PackageName ModuleRenaming - } - | TestComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)], - componentPackageRenaming :: Map PackageName ModuleRenaming - } - | BenchComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)], - componentPackageRenaming :: Map PackageName ModuleRenaming - } - deriving (Read, Show) diff --git a/Language/Haskell/GhcMod/CabalConfig/Extract.hs b/Language/Haskell/GhcMod/CabalConfig/Extract.hs deleted file mode 100644 index ea0c3bd..0000000 --- a/Language/Haskell/GhcMod/CabalConfig/Extract.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE RecordWildCards, CPP, OverloadedStrings #-} - --- | This module facilitates extracting information from Cabal's on-disk --- 'LocalBuildInfo' (@dist/setup-config@). -module Language.Haskell.GhcMod.CabalConfig.Extract ( - CabalConfig - , configDependencies - , configFlags - , getConfig - ) where - -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.Read -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.World - -import qualified Language.Haskell.GhcMod.CabalConfig.Cabal16 as C16 -import qualified Language.Haskell.GhcMod.CabalConfig.Cabal18 as C18 -import qualified Language.Haskell.GhcMod.CabalConfig.Cabal22 as C22 - -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(x,y,z) 1 -#endif - -import Control.Applicative ((<$>)) -import Control.Monad (void, mplus, when) -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except () -#else -import Control.Monad.Error () -#endif -import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) -import Data.Version -import Distribution.Package (InstalledPackageId(..) - , PackageIdentifier(..) - , PackageName(..)) -import Distribution.PackageDescription (FlagAssignment) -import Distribution.Simple.LocalBuildInfo (ComponentName) -import MonadUtils (liftIO) -import Text.ParserCombinators.ReadP - -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - ----------------------------------------------------------------- - --- | 'Show'ed cabal 'LocalBuildInfo' string -newtype CabalConfig = CabalConfig { unCabalConfig :: String } - --- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't --- exist run @cabal configure@ i.e. configure with default options like @cabal --- build@ would do. -getConfig :: (IOish m, GmError m) => Cradle -> m CabalConfig -getConfig crdl = do - liftIO (getCurrentWorld crdl) >>= \world -> - when (isSetupConfigOutOfDate world) configure - - cfg <- liftIO (BS.readFile file) `tryFix` \_ -> - configure `modifyError'` GMECabalConfigure - - liftIO (getCurrentWorld crdl) >>= \world -> - decodeConfig crdl world file cfg - where - file = setupConfigFile crdl - prjDir = cradleRootDir crdl - - configure :: (IOish m, GmError m) => m () - configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] - -decodeConfig :: (IOish m, GmError m) - => Cradle -> World -> FilePath -> ByteString -> m CabalConfig -decodeConfig _crdl _world file bs = CabalConfig <$> gen - --- if cacheOutdated world --- then --- gmLog $ "Regenerating pretty setup-config cache: " ++ prettyConfigCache --- liftIO $ writeFile prettyConfigCache cfg --- else CabalConfig <$> liftIO (readFile prettyConfigCache) - - where - -- cacheOutdated World {..} = - -- case (worldCabalConfig, worldPrettyCabalConfigCache) of - -- (Nothing, _) -> error "decodeConfig: setup-config does not exist." - -- (Just _, Nothing) -> True - -- (Just s, Just p) -> s > p - - gen = case BS8.lines bs of - header:_ -> do - ((_,cabalVer), _) <- parseHeader header - if cabalVer >= (Version [1,22] []) - then prettyPrintBinaryConfig file - else return $ bsToStr bs - [] -> throwError $ GMECabalStateFile GMConfigStateFileNoHeader - -prettyPrintBinaryConfig :: (IOish m, GmError m) - => String -> m String -prettyPrintBinaryConfig file = do - exe <- liftIO $ findLibexecExe "ghc-mod-cabal" - slbi <- readProcess' exe ["print-setup-config", file] - return slbi - -parseHeader :: GmError m - => ByteString -> m ((ByteString, Version), (ByteString, Version)) -parseHeader header = case BS8.words header of - ["Saved", "package", "config", "for", _pkgId , "written", "by", cabalId, "using", compId] -> modifyError (\_ -> GMECabalStateFile GMConfigStateFileBadHeader) $ do - cabalId' <- parsePkgId cabalId - compId' <- parsePkgId compId - return (cabalId', compId') - - _ -> throwError $ GMECabalStateFile GMConfigStateFileNoHeader - -parsePkgId :: (Error e, MonadError e m) => ByteString -> m (ByteString, Version) -parsePkgId bs = - case BS8.split '-' bs of - [pkg, vers] -> return (pkg, parseVer vers) - _ -> throwError noMsg - where - parseVer vers = - let (ver,""):[] = - filter ((=="") . snd) $ readP_to_S parseVersion (bsToStr vers) - in ver - -bsToStr :: ByteString -> String -bsToStr = T.unpack . T.decodeUtf8 - --- strToBs :: String -> ByteString --- strToBs = T.encodeUtf8 . T.pack - --- | Extract list of depencenies for all components from 'CabalConfig' -configDependencies :: PackageIdentifier -> CabalConfig -> [Package] -configDependencies thisPkg config = map fromInstalledPackageId deps - where - deps :: [InstalledPackageId] - deps = case deps16 `mplus` deps18 `mplus` deps22 of - Right ps -> ps - Left msg -> error msg - - -- True if this dependency is an internal one (depends on the library - -- defined in the same package). - internal pkgid = pkgid == thisPkg - - -- Cabal >= 1.22 - deps22 :: Either String [InstalledPackageId] - deps22 = - map fst - <$> filterInternal22 - <$> (readEither =<< extractField (unCabalConfig config) "componentsConfigs") - - filterInternal22 - :: [(ComponentName, C22.ComponentLocalBuildInfo, [ComponentName])] - -> [(InstalledPackageId, C22.PackageIdentifier)] - - filterInternal22 ccfg = [ (ipkgid, pkgid) - | (_,clbi,_) <- ccfg - , (ipkgid, pkgid) <- C22.componentPackageDeps clbi - , not (internal . packageIdentifierFrom22 $ pkgid) ] - - packageIdentifierFrom22 :: C22.PackageIdentifier -> PackageIdentifier - packageIdentifierFrom22 (C22.PackageIdentifier (C22.PackageName myName) myVersion) = - PackageIdentifier (PackageName myName) myVersion - - -- Cabal >= 1.18 && < 1.20 - deps18 :: Either String [InstalledPackageId] - deps18 = - map fst - <$> filterInternal - <$> (readEither =<< extractField (unCabalConfig config) "componentsConfigs") - - filterInternal - :: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])] - -> [(InstalledPackageId, PackageIdentifier)] - - filterInternal ccfg = [ (ipkgid, pkgid) - | (_,clbi,_) <- ccfg - , (ipkgid, pkgid) <- C18.componentPackageDeps clbi - , not (internal pkgid) ] - - -- Cabal 1.16 and below - deps16 :: Either String [InstalledPackageId] - deps16 = map fst <$> filter (not . internal . snd) . nub <$> do - cbi <- concat <$> sequence [ extract "executableConfigs" - , extract "testSuiteConfigs" - , extract "benchmarkConfigs" ] - :: Either String [(String, C16.ComponentLocalBuildInfo)] - - return $ maybe [] C16.componentPackageDeps libraryConfig - ++ concatMap (C16.componentPackageDeps . snd) cbi - where - libraryConfig :: Maybe C16.ComponentLocalBuildInfo - libraryConfig = do - field <- find ("libraryConfig" `isPrefixOf`) (tails $ unCabalConfig config) - clbi <- stripPrefix " = " field - if "Nothing" `isPrefixOf` clbi - then Nothing - else case readMaybe =<< stripPrefix "Just " clbi of - Just x -> x - Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi) - - extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)] - extract field = readConfigs field <$> extractField (unCabalConfig config) field - - readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)] - readConfigs f s = case readEither s of - Right x -> x - Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")" - --- | Extract the cabal flags from the 'CabalConfig' -configFlags :: CabalConfig -> Either String FlagAssignment -configFlags (CabalConfig config) = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags" - --- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable --- error message with lots of context on failure. -extractField :: String -> String -> Either String String -extractField content field = - case extractParens <$> find (field `isPrefixOf`) (tails content) of - Just f -> Right f - Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` content) diff --git a/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs b/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs deleted file mode 100644 index 76e5308..0000000 --- a/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Language.Haskell.GhcMod.CabalConfig.Ghc710 ( - configDependencies - , configFlags - , getConfig - ) where - -import Control.Monad -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, externalPackageDeps) -import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Configure (getConfigStateFile) -import Distribution.Simple.Setup (configConfigurationsFlags) -import Distribution.PackageDescription (FlagAssignment) - -import MonadUtils (liftIO) - -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.World - - --- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't --- exist run @cabal configure@ i.e. configure with default options like @cabal --- build@ would do. -getConfig :: (IOish m, GmError m) - => Cradle - -> m LocalBuildInfo -getConfig cradle = liftIO (getCurrentWorld cradle) >>= \world -> do - when (isSetupConfigOutOfDate world) configure - liftIO (getConfigStateFile file) `tryFix` \_ -> - configure `modifyError'` GMECabalConfigure - where - file = setupConfigFile cradle - prjDir = cradleRootDir cradle - - configure :: (IOish m, GmError m) => m () - configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] - -configDependencies :: a -> LocalBuildInfo -> [Package] -configDependencies _ lbi = - [ fromInstalledPackageId instPkgId - | (instPkgId, _) <- externalPackageDeps lbi ] - - -configFlags :: LocalBuildInfo -> Either String FlagAssignment -configFlags = Right . configConfigurationsFlags . LBI.configFlags diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs new file mode 100644 index 0000000..1542f94 --- /dev/null +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -0,0 +1,104 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +module Language.Haskell.GhcMod.CabalHelper ( + CabalHelper(..) + , getComponents + , getGhcOptions + , getGhcPkgOptions + , cabalHelper + ) where + +import Control.Applicative +import Control.Monad +import Data.Monoid +import Data.List +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.Utils +import Language.Haskell.GhcMod.World +import Language.Haskell.GhcMod.PathsAndFiles +import System.FilePath + +-- | Only package related GHC options, sufficient for things that don't need to +-- access home modules +getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])] +getGhcPkgOptions = chGhcPkgOptions `liftM` cabalHelper + +getGhcOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])] +getGhcOptions = chGhcOptions `liftM` cabalHelper + +-- | Primary interface to cabal-helper and intended single entrypoint to +-- constructing 'GmComponent's +-- +-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by +-- 'resolveGmComponents'. +getComponents :: (MonadIO m, GmEnv m) + => m [GmComponent (Either FilePath [ModuleName])] +getComponents = cabalHelper >>= \CabalHelper {..} -> return $ let + ([(scn, sep)], eps) = partition ((GmSetupHsName ==) . fst) chEntrypoints + sc = GmComponent scn [] [] sep sep ["."] mempty + cs = flip map (zip4 eps chGhcOptions chGhcSrcOptions chSourceDirs) $ + \((cn, ep), (_, opts), (_, srcOpts), (_, srcDirs)) -> + GmComponent cn opts srcOpts ep ep srcDirs mempty + in sc:cs + + +withCabal :: (MonadIO m, GmEnv m) => m a -> m a +withCabal action = do + crdl <- cradle + Options { cabalProgram } <- options + + liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $ + withDirectory_ (cradleRootDir crdl) $ + void $ readProcess cabalProgram ["configure"] "" + + action + +data CabalHelper = CabalHelper { + chEntrypoints :: [(GmComponentName, Either FilePath [ModuleName])], + chSourceDirs :: [(GmComponentName, [String])], + chGhcOptions :: [(GmComponentName, [String])], + chGhcSrcOptions :: [(GmComponentName, [String])], + chGhcPkgOptions :: [(GmComponentName, [String])] + } deriving (Show) + +cabalHelper :: (MonadIO m, GmEnv m) => m CabalHelper +cabalHelper = withCabal $ do + let cmds = [ "entrypoints" + , "source-dirs" + , "ghc-options" + , "ghc-src-options" + , "ghc-pkg-options" ] + + Cradle {..} <- cradle + exe <- liftIO $ findLibexecExe "cabal-helper-wrapper" + + let distdir = cradleRootDir "dist" + + res <- liftIO $ cached cradleRootDir (cabalHelperCache cmds) $ do + out <- readProcess exe (distdir:cmds) "" + evaluate (read out) `catch` + \(SomeException _) -> error "cabalHelper: read failed" + + let [ Just (GmCabalHelperEntrypoints eps), + Just (GmCabalHelperStrings srcDirs), + Just (GmCabalHelperStrings ghcOpts), + Just (GmCabalHelperStrings ghcSrcOpts), + Just (GmCabalHelperStrings ghcPkgOpts) ] = res + + return $ CabalHelper eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index dabb67b..f33f5cf 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -8,17 +8,24 @@ import Data.List (find, intercalate) import Data.Maybe (isJust) import qualified Data.Text as T import qualified Data.Text.IO as T (readFile) +import System.FilePath + import qualified DataCon as Ty -import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import qualified GHC as G -import Language.Haskell.GhcMod.Convert -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.SrcUtils import Outputable (PprStyle) import qualified TyCon as Ty import qualified Type as Ty +import Exception + +import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.DynFlags +import qualified Language.Haskell.GhcMod.Gap as Gap +import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.SrcUtils +import Language.Haskell.GhcMod.Doc +import Language.Haskell.GhcMod.Logging +import Language.Haskell.GhcMod.Types ---------------------------------------------------------------- -- CASE SPLITTING @@ -38,23 +45,29 @@ splits :: IOish m -> Int -- ^ Line number. -> Int -- ^ Column number. -> GhcModT m String -splits file lineNo colNo = ghandle handler body - where - body = inModuleContext file $ \dflag style -> do - opt <- options - modSum <- Gap.fileModSummary file - whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of - (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do - let varName' = showName dflag style varName -- Convert name to string - text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ - getTyCons dflag style varName varT) - return (fourInts bndLoc, text) - (TySplitInfo varName bndLoc (varLoc,varT)) -> do - let varName' = showName dflag style varName -- Convert name to string - text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ - getTyCons dflag style varName varT) - return (fourInts bndLoc, text) - handler (SomeException _) = emptyResult =<< options +splits file lineNo colNo = + runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do + opt <- options + crdl <- cradle + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- Gap.fileModSummary (cradleCurrentDir crdl file) + whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of + (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do + let varName' = showName dflag style varName -- Convert name to string + t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ + getTyCons dflag style varName varT) + return (fourInts bndLoc, t) + (TySplitInfo varName bndLoc (varLoc,varT)) -> do + let varName' = showName dflag style varName -- Convert name to string + t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ + getTyCons dflag style varName varT) + return (fourInts bndLoc, t) + where + handler (SomeException ex) = do + gmLog GmDebug "splits" $ + text "" $$ nest 4 (showDoc ex) + emptyResult =<< options ---------------------------------------------------------------- -- a. Code for getting the information of the variable @@ -180,13 +193,13 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String genCaseSplitTextFile file info = liftIO $ do - text <- T.readFile file - return $ getCaseSplitText (T.lines text) info + t <- T.readFile file + return $ getCaseSplitText (T.lines t) info getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String -getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS +getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS , sVarSpan = sVS, sTycons = sT }) = - let bindingText = getBindingText text sBS + let bindingText = getBindingText t sBS difference = srcSpanDifference sBS sVS replaced = map (replaceVarWithTyCon bindingText difference sVN) sT -- The newly generated bindings need to be indented to align with the @@ -195,9 +208,9 @@ getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS in T.unpack $ T.intercalate (T.pack "\n") (concat replaced') getBindingText :: [T.Text] -> SrcSpan -> [T.Text] -getBindingText text srcSpan = +getBindingText t srcSpan = let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan - lines_ = drop (sl - 1) $ take el text + lines_ = drop (sl - 1) $ take el t in if sl == el then -- only one line [T.drop (sc - 1) $ T.take ec $ head lines_] @@ -212,7 +225,7 @@ srcSpanDifference b v = in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text] -replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon = +replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon = let tycon' = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon lengthDiff = length tycon' - length varname tycon'' = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon' @@ -222,7 +235,7 @@ replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon = else if n == vsl then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line else T.replicate spacesToAdd (T.pack " ") `T.append` line) - [0 ..] text + [0 ..] t indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text] indentBindingTo bndLoc binds = diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index ce8877f..92715fe 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -9,8 +9,7 @@ import Control.Applicative ((<$>)) import Language.Haskell.GhcMod.DynFlags import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Logger -import Language.Haskell.GhcMod.Monad (IOish, GhcModT) -import Language.Haskell.GhcMod.Target (setTargetFiles) +import Language.Haskell.GhcMod.Monad ---------------------------------------------------------------- @@ -29,15 +28,12 @@ checkSyntax files = either id id <$> check files check :: IOish m => [FilePath] -- ^ The target files. -> GhcModT m (Either String String) -{- -check fileNames = overrideGhcUserOptions $ \ghcOpts -> do - withLogger (setAllWarningFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do - _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags - setTargetFiles fileNames --} -check fileNames = - withLogger (setAllWarningFlags . setNoMaxRelevantBindings) $ - setTargetFiles fileNames +check files = + runGmLoadedTWith + (map Left files) + return + ((fmap fst <$>) . withLogger (setAllWarningFlags . setNoMaxRelevantBindings)) + (return ()) ---------------------------------------------------------------- @@ -51,8 +47,10 @@ expandTemplate files = either id id <$> expand files ---------------------------------------------------------------- -- | Expanding Haskell Template. -expand :: IOish m - => [FilePath] -- ^ The target files. - -> GhcModT m (Either String String) -expand fileNames = withLogger (Gap.setDumpSplices . setNoWarningFlags) $ - setTargetFiles fileNames +expand :: IOish m => [FilePath] -> GhcModT m (Either String String) +expand files = + runGmLoadedTWith + (map Left files) + return + ((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags)) + (return ()) diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 862a296..248adde 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -2,7 +2,7 @@ module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where -import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types import Control.Applicative ((<$>)) @@ -23,7 +23,7 @@ inter :: Char -> [Builder] -> Builder inter _ [] = id inter c bs = foldr1 (\x y -> x . (c:) . y) bs -convert' :: (ToString a, IOish m) => a -> GhcModT m String +convert' :: (ToString a, IOish m, GmEnv m) => a -> m String convert' x = flip convert x <$> options convert :: ToString a => Options -> a -> String diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index a5e652f..8aca44a 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -1,19 +1,21 @@ module Language.Haskell.GhcMod.Cradle ( findCradle , findCradle' - , findCradleWithoutSandbox + , findSpecCradle , cleanupCradle ) where -import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils -import Control.Exception.IOChoice ((||>)) -import System.Directory (getCurrentDirectory, removeDirectoryRecursive) -import System.FilePath (takeDirectory) - +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Maybe +import Data.Maybe +import System.Directory +import System.FilePath ---------------------------------------------------------------- @@ -25,51 +27,71 @@ findCradle :: IO Cradle findCradle = findCradle' =<< getCurrentDirectory findCradle' :: FilePath -> IO Cradle -findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir +findCradle' dir = run $ do + (cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir) + where run a = fillTempDir =<< (fromJust <$> runMaybeT a) + +findSpecCradle :: FilePath -> IO Cradle +findSpecCradle dir = do + let cfs = [cabalCradle, sandboxCradle] + cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs + gcs <- filterM isNotGmCradle cs + fillTempDir =<< case gcs of + [] -> fromJust <$> runMaybeT (plainCradle dir) + c:_ -> return c + where + isNotGmCradle :: Cradle -> IO Bool + isNotGmCradle crdl = do + not <$> doesFileExist (cradleRootDir crdl "ghc-mod.cabal") cleanupCradle :: Cradle -> IO () cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl -cabalCradle :: FilePath -> IO Cradle +fillTempDir :: MonadIO m => Cradle -> m Cradle +fillTempDir crdl = do + tmpDir <- liftIO $ newTempDir (cradleRootDir crdl) + return crdl { cradleTempDir = tmpDir } + +cabalCradle :: FilePath -> MaybeT IO Cradle cabalCradle wdir = do - Just cabalFile <- findCabalFile wdir + cabalFile <- MaybeT $ findCabalFile wdir + let cabalDir = takeDirectory cabalFile - pkgDbStack <- getPackageDbStack cabalDir - tmpDir <- newTempDir cabalDir + pkgDbStack <- liftIO $ getPackageDbStack cabalDir + return Cradle { cradleCurrentDir = wdir , cradleRootDir = cabalDir - , cradleTempDir = tmpDir + , cradleTempDir = error "tmpDir" , cradleCabalFile = Just cabalFile , cradlePkgDbStack = pkgDbStack } -sandboxCradle :: FilePath -> IO Cradle +sandboxCradle :: FilePath -> MaybeT IO Cradle sandboxCradle wdir = do - Just sbDir <- findCabalSandboxDir wdir - pkgDbStack <- getPackageDbStack sbDir - tmpDir <- newTempDir sbDir + sbDir <- MaybeT $ findCabalSandboxDir wdir + pkgDbStack <- liftIO $ getPackageDbStack sbDir return Cradle { cradleCurrentDir = wdir , cradleRootDir = sbDir - , cradleTempDir = tmpDir + , cradleTempDir = error "tmpDir" , cradleCabalFile = Nothing , cradlePkgDbStack = pkgDbStack } -plainCradle :: FilePath -> IO Cradle +plainCradle :: FilePath -> MaybeT IO Cradle plainCradle wdir = do - tmpDir <- newTempDir wdir - return Cradle { + return $ Cradle { cradleCurrentDir = wdir , cradleRootDir = wdir - , cradleTempDir = tmpDir + , cradleTempDir = error "tmpDir" , cradleCabalFile = Nothing , cradlePkgDbStack = [GlobalDb, UserDb] } --- Just for testing -findCradleWithoutSandbox :: IO Cradle -findCradleWithoutSandbox = do - cradle <- findCradle - return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME +getPackageDbStack :: FilePath -- ^ Project Directory (where the + -- cabal.sandbox.config file would be if it + -- exists) + -> IO [GhcPkgDb] +getPackageDbStack cdir = + ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index f092d3e..02b4ba7 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -1,41 +1,76 @@ module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where +import Control.Arrow (first) import Control.Applicative ((<$>)) -import Data.List (intercalate) -import Data.Maybe (isJust, fromJust) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Text.PrettyPrint import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.CabalConfig import Language.Haskell.GhcMod.Internal +import Language.Haskell.GhcMod.CabalHelper +import Language.Haskell.GhcMod.Target +import Language.Haskell.GhcMod.Pretty ---------------------------------------------------------------- -- | Obtaining debug information. debugInfo :: IOish m => GhcModT m String -debugInfo = cradle >>= \c -> convert' =<< do - CompilerOptions gopts incDir pkgs <- - if isJust $ cradleCabalFile c then - fromCabalFile c ||> simpleCompilerOption - else - simpleCompilerOption - return [ - "Root directory: " ++ cradleRootDir c - , "Current directory: " ++ cradleCurrentDir c - , "Cabal file: " ++ show (cradleCabalFile c) - , "GHC options: " ++ unwords gopts - , "Include directories: " ++ unwords incDir - , "Dependent packages: " ++ intercalate ", " (map showPkg pkgs) - , "System libraries: " ++ ghcLibDir - ] - where - simpleCompilerOption = options >>= \op -> - return $ CompilerOptions (ghcUserOptions op) [] [] - fromCabalFile crdl = options >>= \opts -> do - config <- cabalGetConfig crdl - pkgDesc <- parseCabalFile config $ fromJust $ cradleCabalFile crdl - getCompilerOptions (ghcUserOptions opts) crdl config pkgDesc +debugInfo = do + Options {..} <- options + Cradle {..} <- cradle + cabal <- + case cradleCabalFile of + Just _ -> cabalDebug + Nothing -> return [] + + return $ unlines $ + [ "Root directory: " ++ cradleRootDir + , "Current directory: " ++ cradleCurrentDir + , "GHC System libraries: " ++ ghcLibDir + , "GHC user options: " ++ render (fsep $ map text ghcUserOptions) + ] ++ cabal + +cabalDebug :: IOish m => GhcModT m [String] +cabalDebug = do + Cradle {..} <- cradle + mcs <- resolveGmComponents Nothing =<< getComponents + let entrypoints = Map.map gmcEntrypoints mcs + graphs = Map.map gmcHomeModuleGraph mcs + opts = Map.map gmcGhcOpts mcs + srcOpts = Map.map gmcGhcSrcOpts mcs + + return $ + [ "Cabal file: " ++ show cradleCabalFile + , "Cabal entrypoints:\n" ++ render (nest 4 $ + mapDoc gmComponentNameDoc smpDoc entrypoints) + , "Cabal components:\n" ++ render (nest 4 $ + mapDoc gmComponentNameDoc graphDoc graphs) + , "GHC Cabal options:\n" ++ render (nest 4 $ + mapDoc gmComponentNameDoc (fsep . map text) opts) + , "GHC search path options:\n" ++ render (nest 4 $ + mapDoc gmComponentNameDoc (fsep . map text) srcOpts) + ] + +graphDoc :: GmModuleGraph -> Doc +graphDoc GmModuleGraph{..} = + mapDoc mpDoc' smpDoc' gmgGraph + where + smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp + mpDoc' = text . moduleNameString . mpModule + +smpDoc :: Set.Set ModulePath -> Doc +smpDoc smp = vcat $ map mpDoc $ Set.toList smp + +mpDoc :: ModulePath -> Doc +mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn) + + +mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc +mapDoc kd ad m = vcat $ + map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m ---------------------------------------------------------------- -- | Obtaining root information. diff --git a/Language/Haskell/GhcMod/Doc.hs b/Language/Haskell/GhcMod/Doc.hs index bbc6b77..5fa485c 100644 --- a/Language/Haskell/GhcMod/Doc.hs +++ b/Language/Haskell/GhcMod/Doc.hs @@ -1,9 +1,8 @@ module Language.Haskell.GhcMod.Doc where -import GHC (DynFlags, GhcMonad) -import qualified GHC as G +import GHC import Language.Haskell.GhcMod.Gap (withStyle, showDocWith) -import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify) +import Outputable import Pretty (Mode(..)) showPage :: DynFlags -> PprStyle -> SDoc -> String @@ -12,9 +11,14 @@ showPage dflag style = showDocWith dflag PageMode . withStyle dflag style showOneLine :: DynFlags -> PprStyle -> SDoc -> String showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style +showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String +showForUser dflags unqual sdoc = + showDocWith dflags PageMode $ + runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay + getStyle :: GhcMonad m => m PprStyle getStyle = do - unqual <- G.getPrintUnqual + unqual <- getPrintUnqual return $ mkUserStyle unqual AllTheWay styleUnqualified :: PprStyle diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs index 5350f16..2c8ee53 100644 --- a/Language/Haskell/GhcMod/DynFlags.hs +++ b/Language/Haskell/GhcMod/DynFlags.hs @@ -12,8 +12,6 @@ import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types import System.IO.Unsafe (unsafePerformIO) -data Build = CabalPkg | SingleFile deriving Eq - setEmptyLogger :: DynFlags -> DynFlags setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return () @@ -41,37 +39,15 @@ setModeIntelligent df = df { , optLevel = 0 } -setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags -setIncludeDirs idirs df = df { importPaths = idirs } - -setBuildEnv :: Build -> DynFlags -> DynFlags -setBuildEnv build = setHideAllPackages build . setCabalPackage build - --- | With ghc-7.8 this option simply makes GHC print a message suggesting users --- add hiddend packages to the build-depends field in their cabal file when the --- user tries to import a module form a hidden package. -setCabalPackage :: Build -> DynFlags -> DynFlags -setCabalPackage CabalPkg df = Gap.setCabalPkg df -setCabalPackage _ df = df - --- | Enable hiding of all package not explicitly exposed (like Cabal does) -setHideAllPackages :: Build -> DynFlags -> DynFlags -setHideAllPackages CabalPkg df = Gap.setHideAllPackages df -setHideAllPackages _ df = df - -- | Parse command line ghc options and add them to the 'DynFlags' passed addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags addCmdOpts cmdOpts df = - tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts) + fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts) where - tfst (a,_,_) = a + fst3 (a,_,_) = a ---------------------------------------------------------------- --- | Return the 'DynFlags' currently in use in the GHC session. -getDynamicFlags :: IO DynFlags -getDynamicFlags = G.runGhc (Just libdir) G.getSessionDynFlags - withDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m a @@ -119,3 +95,7 @@ setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing } #else setNoMaxRelevantBindings = id #endif + +deferErrors :: DynFlags -> Ghc DynFlags +deferErrors df = return $ + Gap.setWarnTypedHoles $ Gap.setDeferTypeErrors $ setNoWarningFlags df diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 23c52a3..73dd672 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-} -- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- @@ -14,64 +13,47 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . + +{-# LANGUAGE ExistentialQuantification #-} module Language.Haskell.GhcMod.Error ( GhcModError(..) , GMConfigStateFileError(..) , GmError , gmeDoc + , ghcExceptionDoc + , liftMaybe + , overrideError , modifyError , modifyError' + , modifyGmError , tryFix + , GHandler(..) + , gcatches , module Control.Monad.Error - , module Exception + , module Control.Exception ) where -import Control.Monad.Error (MonadError(..), Error(..)) +import Control.Arrow +import Control.Exception +import Control.Monad.Error +import qualified Data.Set as Set import Data.List -import Data.Typeable -import Exception +import Data.Version +import System.Process (showCommandForUser) import Text.PrettyPrint +import Text.Printf + +import Exception +import Panic +import Config (cProjectVersion, cHostPlatformString) +import Paths_ghc_mod (version) + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Pretty + type GmError m = MonadError GhcModError m -data GhcModError = GMENoMsg - -- ^ Unknown error - - | GMEString String - -- ^ Some Error with a message. These are produced mostly by - -- 'fail' calls on GhcModT. - - | GMEIOException IOException - -- ^ IOExceptions captured by GhcModT's MonadIO instance - - | GMECabalConfigure GhcModError - -- ^ Configuring a cabal project failed. - - | GMECabalFlags GhcModError - -- ^ Retrieval of the cabal configuration flags failed. - - | GMEProcess [String] GhcModError - -- ^ Launching an operating system process failed. The first - -- field is the command. - - | GMENoCabalFile - -- ^ No cabal file found. - - | GMETooManyCabalFiles [FilePath] - -- ^ Too many cabal files found. - - | GMECabalStateFile GMConfigStateFileError - -- ^ Reading Cabal's state configuration file falied somehow. - deriving (Eq,Show,Typeable) - -data GMConfigStateFileError - = GMConfigStateFileNoHeader - | GMConfigStateFileBadHeader - | GMConfigStateFileNoParse - | GMConfigStateFileMissing --- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) - deriving (Eq, Show, Read, Typeable) - gmCsfeDoc :: GMConfigStateFileError -> Doc gmCsfeDoc GMConfigStateFileNoHeader = text $ "Saved package config file header is missing. " @@ -103,31 +85,45 @@ gmCsfeDoc GMConfigStateFileMissing = text $ -- ++ display currentCompilerId -- ++ ") which is probably the cause of the problem." - - - - -instance Exception GhcModError - -instance Error GhcModError where - noMsg = GMENoMsg - strMsg = GMEString - gmeDoc :: GhcModError -> Doc gmeDoc e = case e of GMENoMsg -> text "Unknown error" GMEString msg -> text msg - GMEIOException ioe -> - text $ show ioe GMECabalConfigure msg -> - text "cabal configure failed: " <> gmeDoc msg + text "Configuring cabal project failed: " <> gmeDoc msg GMECabalFlags msg -> - text "retrieval of the cabal configuration flags failed: " <> gmeDoc msg - GMEProcess cmd msg -> - text ("launching operating system process `"++unwords cmd++"` failed: ") - <> gmeDoc msg + text "Retrieval of the cabal configuration flags failed: " <> gmeDoc msg + GMECabalComponent cn -> + text "Cabal component " <> quotes (gmComponentNameDoc cn) + <> text " could not be found." + GMECabalCompAssignment ctx -> + text "Could not find a consistent component assignment for modules:" $$ + (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$ + empty $$ + text "Try this and that" + + where + ctxDoc = moduleDoc *** compsDoc + >>> first (<> colon) >>> uncurry (flip hang 4) + + moduleDoc (Left fn) = + text "File " <> quotes (text fn) + moduleDoc (Right mdl) = + text "Module " <> quotes (text $ moduleNameString mdl) + + compsDoc sc | Set.null sc = text "has no known components" + compsDoc sc = fsep $ punctuate comma $ + map gmComponentNameDoc $ Set.toList sc + + GMEProcess cmd args emsg -> let c = showCommandForUser cmd args in + case emsg of + Right err -> + text (printf "Launching system command `%s` failed: " c) + <> gmeDoc err + Left (_out, _err, rv) -> text $ + printf "Launching system command `%s` failed (exited with %d)" c rv GMENoCabalFile -> text "No cabal file found." GMETooManyCabalFiles cfs -> @@ -136,6 +132,32 @@ gmeDoc e = case e of GMECabalStateFile csfe -> gmCsfeDoc csfe +ghcExceptionDoc :: GhcException -> Doc +ghcExceptionDoc e@(CmdLineError _) = + text $ ": " ++ showGhcException e "" +ghcExceptionDoc (UsageError str) = strDoc str +ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\ +\GHC panic! (the 'impossible' happened)\n\ +\ ghc-mod version %s\n\ +\ GHC library version %s for %s:\n\ +\ %s\n\ +\\n\ +\Please report this as a bug: %s\n" + gmVer ghcVer platform msg url + where + gmVer = showVersion version + ghcVer = cProjectVersion + platform = cHostPlatformString + url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String + +ghcExceptionDoc e = text $ showGhcException e "" + + +liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a +liftMaybe e action = maybe (throwError e) return =<< action + +overrideError :: MonadError e m => e -> m a -> m a +overrideError e action = modifyError (const e) action modifyError :: MonadError e m => (e -> e) -> m a -> m a modifyError f action = action `catchError` \e -> throwError $ f e @@ -144,6 +166,23 @@ infixr 0 `modifyError'` modifyError' :: MonadError e m => m a -> (e -> e) -> m a modifyError' = flip modifyError + +modifyGmError :: (MonadIO m, ExceptionMonad m) + => (GhcModError -> GhcModError) -> m a -> m a +modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex) + tryFix :: MonadError e m => m a -> (e -> m ()) -> m a -tryFix action fix = do - action `catchError` \e -> fix e >> action +tryFix action f = do + action `catchError` \e -> f e >> action + +data GHandler m a = forall e . Exception e => GHandler (e -> m a) + +gcatches :: ExceptionMonad m => m a -> [GHandler m a] -> m a +gcatches io handlers = io `gcatch` gcatchesHandler handlers + +gcatchesHandler :: ExceptionMonad m => [GHandler m a] -> SomeException -> m a +gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers + where tryHandler (GHandler handler) res + = case fromException e of + Just e' -> handler e' + Nothing -> res diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 8e6f3fa..93d75ee 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -19,8 +19,10 @@ import qualified GHC as G import qualified Name as G import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils +import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.Types import Outputable (PprStyle) import qualified Type as Ty @@ -66,21 +68,29 @@ sig :: IOish m -> Int -- ^ Line number. -> Int -- ^ Column number. -> GhcModT m String -sig file lineNo colNo = ghandle handler body - where - body = inModuleContext file $ \dflag style -> do - opt <- options - modSum <- Gap.fileModSummary file - whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of +sig file lineNo colNo = + runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do + opt <- options + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- Gap.fileModSummary file + whenFound opt (getSignature modSum lineNo colNo) $ \s -> + case s of Signature loc names ty -> - ("function", fourInts loc, map (initialBody dflag style ty) names) - InstanceDecl loc cls -> - ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x) - (Ty.classMethods cls)) + ("function", fourInts loc, map (initialBody dflag style ty) names) + + InstanceDecl loc cls -> let + body x = initialBody dflag style (G.idType x) x + in + ("instance", fourInts loc, body `map` Ty.classMethods cls) + TyFamDecl loc name flavour vars -> let (rTy, initial) = initialTyFamString flavour - in (rTy, fourInts loc, [initial ++ initialFamBody dflag style name vars]) + body = initialFamBody dflag style name vars + in (rTy, fourInts loc, [initial ++ body]) + + where handler (SomeException _) = do opt <- options -- Code cannot be parsed by ghc module @@ -321,10 +331,11 @@ refine :: IOish m -> Int -- ^ Column number. -> Expression -- ^ A Haskell expression. -> GhcModT m String -refine file lineNo colNo expr = ghandle handler body - where - body = inModuleContext file $ \dflag style -> do +refine file lineNo colNo expr = + runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do opt <- options + style <- getStyle + dflag <- G.getSessionDynFlags modSum <- Gap.fileModSummary file p <- G.parseModule modSum tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p @@ -339,7 +350,8 @@ refine file lineNo colNo expr = ghandle handler body text = initialHead1 expr iArgs (infinitePrefixSupply name) in (fourInts loc, doParen paren text) - handler (SomeException _) = emptyResult =<< options + where + handler (SomeException _) = emptyResult =<< options -- Look for the variable in the specified position findVar :: GhcMonad m => DynFlags -> PprStyle @@ -386,10 +398,11 @@ auto :: IOish m -> Int -- ^ Line number. -> Int -- ^ Column number. -> GhcModT m String -auto file lineNo colNo = ghandle handler body - where - body = inModuleContext file $ \dflag style -> do +auto file lineNo colNo = + runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do opt <- options + style <- getStyle + dflag <- G.getSessionDynFlags modSum <- Gap.fileModSummary file p <- G.parseModule modSum tcm@TypecheckedModule { @@ -415,8 +428,8 @@ auto file lineNo colNo = ghandle handler body djinns <- djinn True (Just minfo) env rty (Max 10) 100000 return ( fourInts loc , map (doParen paren) $ nub (djinnsEmpty ++ djinns)) - - handler (SomeException _) = emptyResult =<< options + where + handler (SomeException _) = emptyResult =<< options -- Functions we do not want in completions notWantedFuns :: [String] diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 09c1c4f..452b29c 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -28,7 +28,7 @@ import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Gap (listVisibleModules) import Name (getOccString) -import Module (moduleNameString, moduleName) +import Module (moduleName) import System.Directory (doesFileExist, getModificationTime) import System.FilePath ((), takeDirectory) import System.IO @@ -81,7 +81,7 @@ loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb = do ghcMod <- liftIO ghcModExecutable tmpdir <- cradleTempDir <$> cradle - file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir] + file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] "" !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) return $ SymbolDb { table = db @@ -102,12 +102,12 @@ loadSymbolDb = do -- The file name is printed. dumpSymbol :: IOish m => FilePath -> GhcModT m String -dumpSymbol dir = do +dumpSymbol dir = runGmPkgGhc $ do let cache = dir symbolCacheFile pkgdb = dir packageCache create <- liftIO $ cache `isOlderThan` pkgdb - when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable + when create $ (liftIO . writeSymbolCache cache) =<< getGlobalSymbolTable return $ unlines [cache] writeSymbolCache :: FilePath @@ -127,9 +127,9 @@ isOlderThan cache file = do tFile <- getModificationTime file return $ tCache <= tFile -- including equal just in case --- | Browsing all functions in all system/user modules. -getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])] -getSymbolTable = do +-- | Browsing all functions in all system modules. +getGlobalSymbolTable :: LightGhc [(Symbol,[ModuleString])] +getGlobalSymbolTable = do df <- G.getSessionDynFlags let mods = listVisibleModules df moduleInfos <- mapM G.getModuleInfo mods diff --git a/Language/Haskell/GhcMod/GHCChoice.hs b/Language/Haskell/GhcMod/GHCChoice.hs deleted file mode 100644 index 8ceb214..0000000 --- a/Language/Haskell/GhcMod/GHCChoice.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.GhcMod.GHCChoice where - -import Control.Exception (IOException) -import CoreMonad (liftIO) -import qualified Exception as GE -import GHC (GhcMonad) - ----------------------------------------------------------------- - --- | Try the left 'Ghc' action. If 'IOException' occurs, try --- the right 'Ghc' action. -(||>) :: GhcMonad m => m a -> m a -> m a -x ||> y = x `GE.gcatch` (\(_ :: IOException) -> y) - --- | Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'. -goNext :: GhcMonad m => m a -goNext = liftIO . GE.throwIO $ userError "goNext" - --- | Run any one 'Ghc' monad. -runAnyOne :: GhcMonad m => [m a] -> m a -runAnyOne = foldr (||>) goNext diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 24b511c..f5fbd3f 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -13,7 +13,6 @@ module Language.Haskell.GhcMod.Gap ( , showSeverityCaption , setCabalPkg , setHideAllPackages - , addPackageFlags , setDeferTypeErrors , setWarnTypedHoles , setDumpSplices @@ -33,16 +32,10 @@ module Language.Haskell.GhcMod.Gap ( , fileModSummary , WarnFlags , emptyWarnFlags - , benchmarkBuildInfo - , benchmarkTargets - , toModuleString , GLMatch , GLMatchI , getClass , occName - , setFlags - , ghcVersion - , mkGHCCompilerId , listVisibleModuleNames , listVisibleModules , Language.Haskell.GhcMod.Gap.isSynTyCon @@ -51,19 +44,18 @@ module Language.Haskell.GhcMod.Gap ( import Control.Applicative hiding (empty) import Control.Monad (filterM) import CoreSyn (CoreExpr) -import Data.Version (parseVersion) import Data.List (intersperse) import Data.Maybe (catMaybes) import Data.Time.Clock (UTCTime) +import Data.Traversable (traverse) import DataCon (dataConRepType) import Desugar (deSugarExpr) import DynFlags import ErrUtils +import Exception import FastString import GhcMonad import HscTypes -import Language.Haskell.GhcMod.GHCChoice -import Language.Haskell.GhcMod.Types import NameSet import OccName import Outputable @@ -71,11 +63,8 @@ import PprTyThing import StringBuffer import TcType import Var (varType) -import Config (cProjectVersion) +import System.Directory -import Text.ParserCombinators.ReadP (readP_to_S) - -import qualified Distribution.PackageDescription as P import qualified InstEnv import qualified Pretty import qualified StringBuffer as SB @@ -97,13 +86,6 @@ import Data.Convertible import RdrName (rdrNameOcc) #endif -import Distribution.Version -import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..)) -#if __GLASGOW_HASKELL__ >= 710 -import Distribution.Simple.Compiler (CompilerInfo(..), AbiTag(..)) -import Packages (listVisibleModuleNames, lookupModuleInAllPackages) -#endif - #if __GLASGOW_HASKELL__ < 710 import UniqFM (eltsUFM) import Packages (exposedModules, exposed, pkgIdMap) @@ -112,7 +94,6 @@ import PackageConfig (PackageConfig, packageConfigId) #if __GLASGOW_HASKELL__ >= 704 import qualified Data.IntSet as I (IntSet, empty) -import qualified Distribution.ModuleName as M (ModuleName,toFilePath) #endif ---------------------------------------------------------------- @@ -213,9 +194,11 @@ fOptions = [option | (option,_,_,_) <- fFlags] ---------------------------------------------------------------- fileModSummary :: GhcMonad m => FilePath -> m ModSummary -fileModSummary file = do +fileModSummary file' = do mss <- getModuleGraph - let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss + file <- liftIO $ canonicalizePath file' + [ms] <- liftIO $ flip filterM mss $ \m -> + (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m) return ms withContext :: GhcMonad m => m a -> m a @@ -228,26 +211,31 @@ withContext action = gbracket setup teardown body action topImports = do mss <- getModuleGraph - ms <- map modName <$> filterM isTop mss + mns <- map modName <$> filterM isTop mss + let ii = map IIModule mns #if __GLASGOW_HASKELL__ >= 704 - return ms + return ii #else - return (ms,[]) + return (ii,[]) #endif isTop mos = lookupMod mos ||> returnFalse lookupMod mos = lookupModule (ms_mod_name mos) Nothing >> return True returnFalse = return False #if __GLASGOW_HASKELL__ >= 706 - modName = IIModule . moduleName . ms_mod + modName = moduleName . ms_mod setCtx = setContext #elif __GLASGOW_HASKELL__ >= 704 - modName = IIModule . ms_mod + modName = ms_mod setCtx = setContext #else modName = ms_mod setCtx = uncurry setContext #endif +-- | Try the left action, if an IOException occurs try the right action. +(||>) :: ExceptionMonad m => m a -> m a -> m a +x ||> y = x `gcatch` (\(_ :: IOException) -> y) + showSeverityCaption :: Severity -> String #if __GLASGOW_HASKELL__ >= 706 showSeverityCaption SevWarning = "Warning: " @@ -275,17 +263,6 @@ setHideAllPackages df = gopt_set df Opt_HideAllPackages setHideAllPackages df = dopt_set df Opt_HideAllPackages #endif -addPackageFlags :: [Package] -> DynFlags -> DynFlags -addPackageFlags pkgs df = - df { packageFlags = packageFlags df ++ expose `map` pkgs } - where -#if __GLASGOW_HASKELL__ >= 710 - expose :: Package -> PackageFlag - expose pkg = ExposePackage (PackageIdArg $ showPkgId pkg) (ModRenaming True []) -#else - expose pkg = ExposePackageId $ showPkgId pkg -#endif - ---------------------------------------------------------------- setDumpSplices :: DynFlags -> DynFlags @@ -444,29 +421,6 @@ emptyWarnFlags = [] ---------------------------------------------------------------- ---------------------------------------------------------------- -benchmarkBuildInfo :: P.PackageDescription -> [P.BuildInfo] -#if __GLASGOW_HASKELL__ >= 704 -benchmarkBuildInfo pd = map P.benchmarkBuildInfo $ P.benchmarks pd -#else -benchmarkBuildInfo pd = [] -#endif - -benchmarkTargets :: P.PackageDescription -> [String] -#if __GLASGOW_HASKELL__ >= 704 -benchmarkTargets pd = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd -#else -benchmarkTargets = [] -#endif - -toModuleString :: M.ModuleName -> String -toModuleString mn = fromFilePath $ M.toFilePath mn - where - fromFilePath :: FilePath -> String - fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp - ----------------------------------------------------------------- ----------------------------------------------------------------- - #if __GLASGOW_HASKELL__ >= 708 type GLMatch = LMatch RdrName (LHsExpr RdrName) type GLMatchI = LMatch Id (LHsExpr Id) @@ -502,35 +456,6 @@ occName = rdrNameOcc ---------------------------------------------------------------- -setFlags :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setFlags df = df `gopt_unset` Opt_SpecConstr -- consume memory if -O2 -#else -setFlags = id -#endif - ----------------------------------------------------------------- - -ghcVersion :: Version -ghcVersion = - case readP_to_S parseVersion $ cProjectVersion of - [(ver, "")] -> ver - _ -> error "parsing ghc version(cProjectVersion) failed." - - -#if __GLASGOW_HASKELL__ >= 710 -mkGHCCompilerId :: Version -> Distribution.Simple.Compiler.CompilerInfo --- TODO we should probably fill this out properly -mkGHCCompilerId v = - CompilerInfo (CompilerId GHC v) NoAbiTag Nothing Nothing Nothing -#else -mkGHCCompilerId :: Version -> CompilerId -mkGHCCompilerId v = CompilerId GHC v -#endif - ----------------------------------------------------------------- - - #if __GLASGOW_HASKELL__ < 710 -- Copied from ghc/InteractiveUI.hs allExposedPackageConfigs :: DynFlags -> [PackageConfig] diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index 56dc123..7eaa2ed 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -4,20 +4,14 @@ module Language.Haskell.GhcMod.GhcPkg ( , ghcPkgDbStackOpts , ghcDbStackOpts , ghcDbOpt - , fromInstalledPackageId - , fromInstalledPackageId' - , getPackageDbStack , getPackageCachePaths ) where import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) import Control.Applicative ((<$>)) -import Data.List (intercalate) import Data.List.Split (splitOn) import Data.Maybe -import Distribution.Package (InstalledPackageId(..)) import Exception (handleIO) -import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import System.Directory (doesDirectoryExist, getAppUserDataDirectory) import System.FilePath (()) @@ -25,29 +19,6 @@ import System.FilePath (()) ghcVersion :: Int ghcVersion = read cProjectVersionInt -getPackageDbStack :: FilePath -- ^ Project Directory (where the - -- cabal.sandbox.config file would be if it - -- exists) - -> IO [GhcPkgDb] -getPackageDbStack cdir = - ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir - ----------------------------------------------------------------- - -fromInstalledPackageId' :: InstalledPackageId -> Maybe Package -fromInstalledPackageId' pid = let - InstalledPackageId pkg = pid - in case reverse $ splitOn "-" pkg of - i:v:rest -> Just (intercalate "-" (reverse rest), v, i) - _ -> Nothing - -fromInstalledPackageId :: InstalledPackageId -> Package -fromInstalledPackageId pid = - case fromInstalledPackageId' pid of - Just p -> p - Nothing -> error $ - "fromInstalledPackageId: `"++show pid++"' is not a valid package-id" - ---------------------------------------------------------------- -- | Get options needed to add a list of package dbs to ghc-pkg's db stack @@ -82,12 +53,10 @@ ghcDbOpt (PackageDb pkgDb) ---------------------------------------------------------------- - getPackageCachePaths :: FilePath -> Cradle -> IO [FilePath] getPackageCachePaths sysPkgCfg crdl = catMaybes <$> resolvePackageConfig sysPkgCfg `mapM` cradlePkgDbStack crdl - -- TODO: use PkgConfRef --- Copied from ghc module `Packages' unfortunately it's not exported :/ resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath) diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs new file mode 100644 index 0000000..f15afc1 --- /dev/null +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -0,0 +1,270 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-} +module Language.Haskell.GhcMod.HomeModuleGraph ( + GmModuleGraph(..) + , ModulePath(..) + , mkFileMap + , mkModuleMap + , mkMainModulePath + , findModulePath + , findModulePathSet + , fileModuleName + , homeModuleGraph + , updateHomeModuleGraph + , reachable + , moduleGraphToDot + ) where + +import Bag +import DriverPipeline hiding (unP) +import ErrUtils +import Exception +import FastString +import Finder +import GHC +import HscTypes +import Lexer +import MonadUtils hiding (foldrM) +import Parser +import SrcLoc +import StringBuffer + +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Control.Monad.State.Strict (execStateT) +import Control.Monad.State.Class +import Data.Maybe +import Data.Monoid +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import System.FilePath + +import Language.Haskell.GhcMod.Logging +import Language.Haskell.GhcMod.Logger +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Types + +-- | Turn module graph into a graphviz dot file +-- +-- @dot -Tpng -o modules.png modules.dot@ +moduleGraphToDot :: GmModuleGraph -> String +moduleGraphToDot GmModuleGraph { gmgGraph } = + "digraph {\n" ++ concatMap edges (Map.toList graph) ++ "}\n" + where + graph = Map.map (Set.mapMonotonic mpPath) + $ Map.mapKeysMonotonic mpPath gmgGraph + edges :: (FilePath, (Set FilePath)) -> String + edges (f, sf) = + concatMap (\f' -> " \""++ f ++"\" -> \""++ f' ++"\"\n") (Set.toList sf) + +data S = S { + sErrors :: [(ModulePath, ErrorMessages)], + sWarnings :: [(ModulePath, WarningMessages)], + sGraph :: GmModuleGraph +} + +defaultS :: S +defaultS = S [] [] mempty + +putErr :: MonadState S m + => (ModulePath, ErrorMessages) -> m () +putErr e = do + s <- get + put s { sErrors = e:sErrors s} + +putWarn :: MonadState S m + => (ModulePath, ErrorMessages) -> m () +putWarn w = do + s <- get + put s { sWarnings = w:sWarnings s} + +gmgLookupMP :: MonadState S m => ModulePath -> m (Maybe (Set ModulePath)) +gmgLookupMP k = (Map.lookup k . gmgGraph . sGraph) `liftM` get + +graphUnion :: MonadState S m => GmModuleGraph -> m () +graphUnion gmg = do + s <- get + put s { sGraph = sGraph s `mappend` gmg } + +reachable :: Set ModulePath -> GmModuleGraph -> Set ModulePath +reachable smp0 GmModuleGraph {..} = go smp0 + where + go smp = let + δsmp = Set.unions $ + collapseMaybeSet . flip Map.lookup gmgGraph <$> Set.toList smp + smp' = smp `Set.union` δsmp + in if smp == smp' then smp' else go smp' + +pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph +pruneUnreachable smp0 gmg@GmModuleGraph {..} = let + r = reachable smp0 gmg + rfn = Set.map mpPath r + rmn = Set.map mpModule r + in + GmModuleGraph { + gmgFileMap = Map.filterWithKey (\k _ -> k `Set.member` rfn) gmgFileMap, + gmgModuleMap = Map.filterWithKey (\k _ -> k `Set.member` rmn) gmgModuleMap, + gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph + } + +collapseMaybeSet :: Maybe (Set a) -> Set a +collapseMaybeSet = maybe Set.empty id + +homeModuleGraph :: (IOish m, GmLog m, GmEnv m) + => HscEnv -> Set ModulePath -> m GmModuleGraph +homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp + +mkMainModulePath :: FilePath -> ModulePath +mkMainModulePath = ModulePath (mkModuleName "Main") + +findModulePath :: HscEnv -> ModuleName -> IO (Maybe ModulePath) +findModulePath env mn = do + fmap (ModulePath mn) <$> find env mn + +findModulePathSet :: HscEnv -> [ModuleName] -> IO (Set ModulePath) +findModulePathSet env mns = do + Set.fromList . catMaybes <$> findModulePath env `mapM` mns + +find :: MonadIO m => HscEnv -> ModuleName -> m (Maybe FilePath) +find env mn = liftIO $ do + res <- findHomeModule env mn + case res of + -- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc + Found loc@ModLocation { ml_hs_file = Just _ } _mod -> do + return $ normalise <$> ml_hs_file loc + _ -> return Nothing + +updateHomeModuleGraph :: (IOish m, GmLog m, GmEnv m) + => HscEnv + -> GmModuleGraph + -> Set ModulePath -- ^ Initial set of modules + -> Set ModulePath -- ^ Updated set of modules + -> m GmModuleGraph +updateHomeModuleGraph env GmModuleGraph {..} smp usmp = do + -- TODO: It would be good if we could retain information about modules that + -- stop to compile after we've already successfully parsed them at some + -- point. Figure out a way to delete the modules about to be updated only + -- after we're sure they won't fail to parse .. or something. Should probably + -- push this whole prune logic deep into updateHomeModuleGraph' + (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env usmp) + where + runS = flip execStateT defaultS { sGraph = graph' } + graph' = GmModuleGraph { + gmgFileMap = Set.foldr (Map.delete . mpPath) gmgFileMap usmp, + gmgModuleMap = Set.foldr (Map.delete . mpModule) gmgModuleMap usmp, + gmgGraph = Set.foldr Map.delete gmgGraph usmp + } + +mkFileMap :: Set ModulePath -> Map FilePath ModulePath +mkFileMap smp = Map.fromList $ map (mpPath &&& id) $ Set.toList smp + +mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath +mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp + +updateHomeModuleGraph' + :: forall m. (MonadState S m, IOish m, GmLog m, GmEnv m) + => HscEnv + -> Set ModulePath -- ^ Initial set of modules + -> m () +updateHomeModuleGraph' env smp0 = do + go `mapM_` Set.toList smp0 + + where + go :: ModulePath -> m () + go mp = do + msmp <- gmgLookupMP mp + case msmp of + Just _ -> return () + Nothing -> do + smp <- collapseMaybeSet `liftM` step mp + + graphUnion GmModuleGraph { + gmgFileMap = mkFileMap smp, + gmgModuleMap = mkModuleMap smp, + gmgGraph = Map.singleton mp smp + } + + mapM_ go (Set.toList smp) + + step :: ModulePath -> m (Maybe (Set ModulePath)) + step mp = runMaybeT $ do + (dflags, ppsrc_fn) <- MaybeT preprocess' + src <- liftIO $ readFile ppsrc_fn + imports mp src dflags + where + preprocess' :: m (Maybe (DynFlags, FilePath)) + preprocess' = do + let fn = mpPath mp + ep <- liftIO $ withLogger' env $ \setDf -> let + env' = env { hsc_dflags = setDf (hsc_dflags env) } + in preprocess env' (fn, Nothing) + case ep of + Right (_, x) -> return $ Just x + Left errs -> do + -- TODO: Remember these and present them as proper errors if this is + -- the file the user is looking at. + gmLog GmWarning "preprocess'" $ vcat $ map strDoc errs + return Nothing + + imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath) + imports mp@ModulePath {..} src dflags = + case parseModuleHeader src dflags mpPath of + Left err -> do + putErr (mp, err) + mzero + + Right (ws, lmdl) -> do + putWarn (mp, ws) + let HsModule {..} = unLoc lmdl + mns = map (unLoc . ideclName) + $ filter (isNothing . ideclPkgQual) + $ map unLoc hsmodImports + liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns + +fileModuleName :: HscEnv + -> FilePath + -> IO (Either ErrorMessages (Maybe ModuleName)) +fileModuleName env fn = handle (\(_ :: SomeException) -> return $ Right Nothing) $ do + src <- readFile fn + case parseModuleHeader src (hsc_dflags env) fn of + Left errs -> return (Left errs) + Right (_, lmdl) -> do + let HsModule {..} = unLoc lmdl + return $ Right $ unLoc <$> hsmodName + +parseModuleHeader + :: String -- ^ Haskell module source text (full Unicode is supported) + -> DynFlags + -> FilePath -- ^ the filename (for source locations) + -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) +parseModuleHeader str dflags filename = + let + loc = mkRealSrcLoc (mkFastString filename) 1 1 + buf = stringToStringBuffer str + in + case unP Parser.parseHeader (mkPState dflags buf loc) of + + PFailed sp err -> + Left (unitBag (mkPlainErrMsg dflags sp err)) + + POk pst rdr_module -> + let (warns,_) = getMessages pst in + Right (warns, rdr_module) diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index b58b53f..b376c90 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -7,16 +7,20 @@ import Control.Applicative ((<$>)) import Data.Function (on) import Data.List (sortBy) import Data.Maybe (catMaybes) +import System.FilePath import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) import qualified GHC as G -import Language.Haskell.GhcMod.Doc (showPage) -import Language.Haskell.GhcMod.Gap (HasType(..)) import qualified Language.Haskell.GhcMod.Gap as Gap + +import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.Doc +import Language.Haskell.GhcMod.DynFlags +import Language.Haskell.GhcMod.Gap +import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Convert ---------------------------------------------------------------- @@ -25,14 +29,21 @@ info :: IOish m => FilePath -- ^ A target file. -> Expression -- ^ A Haskell expression. -> GhcModT m String -info file expr = do +info file expr = runGmLoadedT' [Left file] deferErrors $ withContext $ do opt <- options convert opt <$> ghandle handler body where - body = inModuleContext file $ \dflag style -> do + handler (SomeException ex) = do + gmLog GmException "info" $ + text "" $$ nest 4 (showDoc ex) + return "Cannot show info" + + body = do sdoc <- Gap.infoThing expr - return $ showPage dflag style sdoc - handler (SomeException _) = return "Cannot show info" + st <- getStyle + dflag <- G.getSessionDynFlags + return $ showPage dflag st sdoc + ---------------------------------------------------------------- @@ -42,15 +53,18 @@ types :: IOish m -> Int -- ^ Line number. -> Int -- ^ Column number. -> GhcModT m String -types file lineNo colNo = do - opt <- options - convert opt <$> ghandle handler body - where - body = inModuleContext file $ \dflag style -> do - modSum <- Gap.fileModSummary file +types file lineNo colNo = + runGmLoadedT' [Left file] deferErrors $ ghandle handler $ withContext $ do + crdl <- cradle + modSum <- Gap.fileModSummary (cradleCurrentDir crdl file) srcSpanTypes <- getSrcSpanType modSum lineNo colNo - return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes - handler (SomeException _) = return [] + + dflag <- G.getSessionDynFlags + st <- getStyle + + convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes + where + handler (SomeException _) = return [] getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] getSrcSpanType modSum lineNo colNo = do diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index 12311fd..1e01d7b 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -8,28 +8,16 @@ module Language.Haskell.GhcMod.Internal ( , PackageVersion , PackageId , IncludeDir - , CompilerOptions(..) - -- * Cabal API - , parseCabalFile - , getCompilerOptions - , cabalAllBuildInfo - , cabalSourceDirs -- * Various Paths , ghcLibDir , ghcModExecutable - -- * IO - , getDynamicFlags - -- * Targets - , setTargetFiles -- * Logging , withLogger , setNoWarningFlags , setAllWarningFlags -- * Environment, state and logging , GhcModEnv(..) - , newGhcModEnv , GhcModState - , defaultState , CompilerMode(..) , GhcModLog -- * Monad utilities @@ -43,10 +31,6 @@ module Language.Haskell.GhcMod.Internal ( , withOptions -- * 'GhcModError' , gmeDoc - -- * 'GhcMonad' Choice - , (||>) - , goNext - , runAnyOne -- * World , World , getCurrentWorld @@ -55,13 +39,10 @@ module Language.Haskell.GhcMod.Internal ( import GHC.Paths (libdir) -import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 5723e47..088c251 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -1,30 +1,30 @@ -{-# LANGUAGE CPP #-} - module Language.Haskell.GhcMod.Logger ( withLogger + , withLogger' , checkErrorPrefix ) where -import Bag (Bag, bagToList) +import Control.Arrow import Control.Applicative ((<$>)) -import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) -import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo) -import Exception (ghandle) -import GHC (DynFlags, SrcSpan, Severity(SevError)) -import qualified GHC as G -import HscTypes (SourceError, srcErrorMessages) -import Language.Haskell.GhcMod.Doc (showPage, getStyle) -import Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags) -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Convert (convert') -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Types -import Outputable (PprStyle, SDoc) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import System.FilePath (normalise) +import Text.PrettyPrint ----------------------------------------------------------------- +import Bag (Bag, bagToList) +import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo) +import GHC (DynFlags, SrcSpan, Severity(SevError)) +import HscTypes +import Outputable +import qualified GHC as G + +import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.Doc (showPage) +import Language.Haskell.GhcMod.DynFlags (withDynFlags) +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Error +import qualified Language.Haskell.GhcMod.Gap as Gap type Builder = [String] -> [String] @@ -38,16 +38,16 @@ emptyLog = Log [] id newLogRef :: IO LogRef newLogRef = LogRef <$> newIORef emptyLog -readAndClearLogRef :: IOish m => LogRef -> GhcModT m String +readAndClearLogRef :: LogRef -> IO [String] readAndClearLogRef (LogRef ref) = do - Log _ b <- liftIO $ readIORef ref - liftIO $ writeIORef ref emptyLog - convert' (b []) + Log _ b <- readIORef ref + writeIORef ref emptyLog + return $ b [] appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () -appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update +appendLogRef df (LogRef ref) _ sev src st msg = modifyIORef ref update where - l = ppMsg src sev df style msg + l = ppMsg src sev df st msg update lg@(Log ls b) | l `elem` ls = lg | otherwise = Log (l:ls) (b . (l:)) @@ -57,56 +57,68 @@ appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update -- | Set the session flag (e.g. "-Wall" or "-w:") then -- executes a body. Logged messages are returned as 'String'. -- Right is success and Left is failure. -withLogger :: IOish m +withLogger :: (GmGhc m, GmEnv m) => (DynFlags -> DynFlags) - -> GhcModT m () - -> GhcModT m (Either String String) -withLogger setDF body = ghandle sourceError $ do - logref <- liftIO newLogRef - wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options - withDynFlags (setLogger logref . setDF) $ - withCmdFlags wflags $ do - body - Right <$> readAndClearLogRef logref + -> m a + -> m (Either String (String, a)) +withLogger f action = do + env <- G.getSession + opts <- options + let conv = convert opts + eres <- withLogger' env $ \setDf -> + withDynFlags (f . setDf) action + return $ either (Left . conv) (Right . first conv) eres + +withLogger' :: IOish m + => HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a)) +withLogger' env action = do + logref <- liftIO $ newLogRef + + let dflags = hsc_dflags env + pu = icPrintUnqual dflags (hsc_IC env) + st = mkUserStyle pu AllTheWay + + fn df = setLogger logref df + + a <- gcatches (Right <$> action fn) (handlers dflags st) + ls <- liftIO $ readAndClearLogRef logref + + return $ ((,) ls <$> a) + where setLogger logref df = Gap.setLogAction df $ appendLogRef df logref + handlers df st = [ + GHandler $ \ex -> return $ Left $ sourceError df st ex, + GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex] + ] ---------------------------------------------------------------- -- | Converting 'SourceError' to 'String'. -sourceError :: IOish m => SourceError -> GhcModT m (Either String String) -sourceError err = errBagToStr (srcErrorMessages err) - -errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String) -errBagToStr = errBagToStr' Left - -errBagToStr' :: IOish m => (String -> a) -> Bag ErrMsg -> GhcModT m a -errBagToStr' f err = do - dflags <- G.getSessionDynFlags - style <- getStyle - ret <- convert' (errBagToStrList dflags style err) - return $ f ret +sourceError :: DynFlags -> PprStyle -> SourceError -> [String] +sourceError df st src_err = errBagToStrList df st $ srcErrorMessages src_err errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] -errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList +errBagToStrList df st = map (ppErrMsg df st) . reverse . bagToList ---------------------------------------------------------------- ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String -ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ (if null ext then "" else "\n" ++ ext) +ppErrMsg dflag st err = + ppMsg spn SevError dflag st msg ++ (if null ext then "" else "\n" ++ ext) where spn = Gap.errorMsgSpan err msg = errMsgShortDoc err - ext = showPage dflag style (errMsgExtraInfo err) + ext = showPage dflag st (errMsgExtraInfo err) ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String -ppMsg spn sev dflag style msg = prefix ++ cts +ppMsg spn sev dflag st msg = prefix ++ cts where - cts = showPage dflag style msg - prefix = ppMsgPrefix spn sev dflag style cts + cts = showPage dflag st msg + prefix = ppMsgPrefix spn sev dflag st cts ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String -ppMsgPrefix spn sev dflag _style cts = +ppMsgPrefix spn sev dflag _st cts = let defaultPrefix | Gap.isDumpSplices dflag = "" | otherwise = checkErrorPrefix diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index e377d06..63c465f 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -1,4 +1,3 @@ -module Language.Haskell.GhcMod.Logging where -- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- @@ -15,22 +14,45 @@ module Language.Haskell.GhcMod.Logging where -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types +module Language.Haskell.GhcMod.Logging ( + module Language.Haskell.GhcMod.Logging + , module Language.Haskell.GhcMod.Pretty + , GmLogLevel(..) + , module Text.PrettyPrint + , module Data.Monoid + ) where -import Control.Monad.Journal.Class -import Control.Monad.Trans.Class +import Control.Monad +import Data.Monoid (mempty, mappend, mconcat, (<>)) import System.IO +import Text.PrettyPrint hiding (style, (<>)) -import MonadUtils +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Pretty ---gmSink :: IOish m => (GhcModLog -> IO ()) -> GhcModT m () ---gmSink = GhcModT . (lift . lift . sink) +gmSetLogLevel :: GmLog m => GmLogLevel -> m () +gmSetLogLevel level = + gmlJournal $ GhcModLog (Just level) [] -type GmLog m = MonadJournal GhcModLog m +increaseLogLevel :: GmLogLevel -> GmLogLevel +increaseLogLevel l | l == maxBound = l +increaseLogLevel l = succ l -gmJournal :: IOish m => GhcModLog -> GhcModT m () -gmJournal = GhcModT . lift . lift . journal +-- | +-- >>> Just GmDebug <= Nothing +-- False +-- >>> Just GmException <= Just GmDebug +-- True +-- >>> Just GmDebug <= Just GmException +-- False +gmLog :: (MonadIO m, GmLog m) => GmLogLevel -> String -> Doc -> m () +gmLog level loc' doc = do + GhcModLog { gmLogLevel = level' } <- gmlHistory -gmLog :: (MonadIO m, MonadJournal GhcModLog m) => String -> m () -gmLog str = liftIO (hPutStrLn stderr str) >> (journal $ GhcModLog [str]) + let loc | loc' == "" = empty + | otherwise = text (head $ lines loc') <> colon + msg = gmRenderDoc $ gmLogLevelDoc level <+> loc <+> doc + + when (Just level <= level') $ + liftIO $ hPutStrLn stderr msg + gmlJournal (GhcModLog Nothing [(level, render loc, msg)]) diff --git a/Language/Haskell/GhcMod/Modules.hs b/Language/Haskell/GhcMod/Modules.hs index 47fd76c..3a2c024 100644 --- a/Language/Haskell/GhcMod/Modules.hs +++ b/Language/Haskell/GhcMod/Modules.hs @@ -1,6 +1,5 @@ module Language.Haskell.GhcMod.Modules (modules) where -import Control.Applicative ((<$>)) import qualified GHC as G import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad @@ -10,5 +9,7 @@ import Module (moduleNameString) ---------------------------------------------------------------- -- | Listing installed modules. -modules :: IOish m => GhcModT m String -modules = convert' =<< map moduleNameString . listVisibleModuleNames <$> G.getSessionDynFlags +modules :: (IOish m, GmEnv m) => m String +modules = do + dflags <- runGmPkgGhc G.getSessionDynFlags + convert' $ map moduleNameString $ listVisibleModuleNames dflags diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 8c36681..e10a707 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP, RecordWildCards #-} -- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- @@ -14,166 +13,74 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . + +{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.Monad ( - -- * Monad Types - GhcModT - , IOish - -- ** Environment, state and logging - , GhcModEnv(..) - , newGhcModEnv - , GhcModState(..) - , defaultState - , CompilerMode(..) - , GhcModLog - , GhcModError(..) - -- * Monad utilities - , runGhcModT + runGhcModT , runGhcModT' + , runGhcModT'' , hoistGhcModT - -- ** Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog' - , gmsGet - , gmsPut - , gmLog - , options - , cradle - , getCompilerMode - , setCompilerMode - , withOptions - , withTempSession - -- ** Re-exporting convenient stuff - , liftIO - , module Control.Monad.Reader.Class + , runGmLoadedT + , runGmLoadedT' + , runGmLoadedTWith + , runGmPkgGhc + , withGhcModEnv + , withGhcModEnv' + , module Language.Haskell.GhcMod.Monad.Types ) where import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Cradle -import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.CabalApi -import Language.Haskell.GhcMod.CabalConfig -import qualified Language.Haskell.GhcMod.Gap as Gap - -import GHC -import qualified GHC as G -import GHC.Paths (libdir) -import GhcMonad hiding (withTempSession) -#if __GLASGOW_HASKELL__ <= 702 -import HscTypes -#endif - --- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. --- RWST does not automatically become an instance of MonadIO. --- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. --- So, RWST automatically becomes an instance of MonadIO. -import MonadUtils +import Language.Haskell.GhcMod.Target import Control.Arrow (first) -import Control.Monad (void) -#if !MIN_VERSION_monad_control(1,0,0) -import Control.Monad (liftM) -#endif -import Control.Monad.Base (liftBase) +import Control.Applicative -import Control.Monad.Reader.Class -import Control.Monad.State.Class (MonadState(..)) - -import Control.Monad.Error (runErrorT) import Control.Monad.Reader (runReaderT) import Control.Monad.State.Strict (runStateT) import Control.Monad.Trans.Journal (runJournalT) -import Data.Maybe (isJust) -import Data.IORef -import System.Directory (getCurrentDirectory) +import Exception (ExceptionMonad(..)) ----------------------------------------------------------------- +import System.Directory --- | Initialize the 'DynFlags' relating to the compilation of a single --- file or GHC session according to the 'Cradle' and 'Options' --- provided. -initializeFlagsWithCradle :: (IOish m, GhcMonad m, GmError m, GmLog m) - => Options - -> Cradle - -> CabalConfig - -> m () -initializeFlagsWithCradle opt c config - | cabal = withCabal - | otherwise = withSandbox - where - mCabalFile = cradleCabalFile c +withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a +withCradle cradledir f = + gbracket (liftIO $ findCradle' cradledir) (liftIO . cleanupCradle) f - cabal = isJust mCabalFile +withGhcModEnv :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a +withGhcModEnv dir opt f = withCradle dir (withGhcModEnv' opt f) - ghcopts = ghcUserOptions opt - - withCabal = do - let Just cabalFile = mCabalFile - pkgDesc <- parseCabalFile config cabalFile - compOpts <- getCompilerOptions ghcopts c config pkgDesc - initSession CabalPkg opt compOpts - - withSandbox = initSession SingleFile opt compOpts - where - importDirs = [".","..","../..","../../..","../../../..","../../../../.."] - - pkgOpts = ghcDbStackOpts $ cradlePkgDbStack c - - compOpts - | null pkgOpts = CompilerOptions ghcopts importDirs [] - | otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] [] - - (wdir, rdir) = (cradleCurrentDir c, cradleRootDir c) - -initSession :: GhcMonad m - => Build - -> Options - -> CompilerOptions - -> m () -initSession build Options {..} CompilerOptions {..} = do - df <- G.getSessionDynFlags - void $ G.setSessionDynFlags =<< addCmdOpts ghcOptions - ( setModeSimple - $ Gap.setFlags - $ setIncludeDirs includeDirs - $ setBuildEnv build - $ setEmptyLogger - $ Gap.addPackageFlags depPackages df) - ----------------------------------------------------------------- - -newGhcModEnv :: Options -> FilePath -> IO GhcModEnv -newGhcModEnv opt dir = do - session <- newIORef (error "empty session") - c <- findCradle' dir - return GhcModEnv { - gmGhcSession = session - , gmOptions = opt - , gmCradle = c - } - -cleanupGhcModEnv :: GhcModEnv -> IO () -cleanupGhcModEnv env = cleanupCradle $ gmCradle env +withGhcModEnv' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a +withGhcModEnv' opt f crdl = do + olddir <- liftIO getCurrentDirectory + gbracket_ (liftIO $ setCurrentDirectory $ cradleRootDir crdl) + (liftIO $ setCurrentDirectory olddir) + (f $ GhcModEnv opt crdl) + where + gbracket_ ma mb mc = gbracket ma (const mb) (const mc) -- | Run a @GhcModT m@ computation. runGhcModT :: IOish m => Options -> GhcModT m a -> m (Either GhcModError a, GhcModLog) -runGhcModT opt action = gbracket newEnv delEnv $ \env -> do - r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do - dflags <- getSessionDynFlags - defaultCleanupHandler dflags $ do - config <- cabalGetConfig =<< cradle - initializeFlagsWithCradle opt (gmCradle env) config - action ) - return r +runGhcModT opt action = do + dir <- liftIO getCurrentDirectory + runGhcModT' dir opt action - where - newEnv = liftBase $ newGhcModEnv opt =<< getCurrentDirectory - delEnv = liftBase . cleanupGhcModEnv +runGhcModT' :: IOish m + => FilePath + -> Options + -> GhcModT m a + -> m (Either GhcModError a, GhcModLog) +runGhcModT' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> + withGhcModEnv dir' opt $ \env -> + first (fst <$>) <$> runGhcModT'' env defaultGhcModState + (gmSetLogLevel (logLevel opt) >> action) -- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT -- computation. Note that if the computation that returned @result@ modified the @@ -182,7 +89,7 @@ hoistGhcModT :: IOish m => (Either GhcModError a, GhcModLog) -> GhcModT m a hoistGhcModT (r,l) = do - gmJournal l >> case r of + gmlJournal l >> case r of Left e -> throwError e Right a -> return a @@ -191,57 +98,10 @@ hoistGhcModT (r,l) = do -- do with 'GhcModEnv' and 'GhcModState'. -- -- You should probably look at 'runGhcModT' instead. -runGhcModT' :: IOish m - => GhcModEnv - -> GhcModState - -> GhcModT m a - -> m (Either GhcModError (a, GhcModState), GhcModLog) -runGhcModT' r s a = do - (res, w') <- - flip runReaderT r $ runJournalT $ runErrorT $ - runStateT (unGhcModT $ initGhcMonad (Just libdir) >> a) s - return (res, w') ----------------------------------------------------------------- --- | Make a copy of the 'gmGhcSession' IORef, run the action and restore the --- original 'HscEnv'. -withTempSession :: IOish m => GhcModT m a -> GhcModT m a -withTempSession action = do - session <- gmGhcSession <$> ask - savedHscEnv <- liftIO $ readIORef session - a <- action - liftIO $ writeIORef session savedHscEnv - return a - ----------------------------------------------------------------- - -gmeAsk :: IOish m => GhcModT m GhcModEnv -gmeAsk = ask - -gmsGet :: IOish m => GhcModT m GhcModState -gmsGet = GhcModT get - -gmsPut :: IOish m => GhcModState -> GhcModT m () -gmsPut = GhcModT . put - -options :: IOish m => GhcModT m Options -options = gmOptions <$> gmeAsk - -cradle :: IOish m => GhcModT m Cradle -cradle = gmCradle <$> gmeAsk - -getCompilerMode :: IOish m => GhcModT m CompilerMode -getCompilerMode = gmCompilerMode <$> gmsGet - -setCompilerMode :: IOish m => CompilerMode -> GhcModT m () -setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet - ----------------------------------------------------------------- - -withOptions :: IOish m => (Options -> Options) -> GhcModT m a -> GhcModT m a -withOptions changeOpt action = local changeEnv action - where - changeEnv e = e { gmOptions = changeOpt opt } - where - opt = gmOptions e - ----------------------------------------------------------------- +runGhcModT'' :: IOish m + => GhcModEnv + -> GhcModState + -> GhcModT m a + -> m (Either GhcModError (a, GhcModState), GhcModLog) +runGhcModT'' r s a = do + flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGhcModT a) s diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 0c454bc..5ad2f6f 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -16,13 +16,45 @@ {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} -{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-} +{-# LANGUAGE StandaloneDeriving, InstanceSigs #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Language.Haskell.GhcMod.Monad.Types where - +module Language.Haskell.GhcMod.Monad.Types ( + -- * Monad Types + GhcModT(..) + , GmLoadedT(..) + , LightGhc(..) + , GmGhc + , IOish + -- ** Environment, state and logging + , GhcModEnv(..) + , GhcModState(..) + , defaultGhcModState + , GmGhcSession(..) + , GmComponent(..) + , CompilerMode(..) + -- ** Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog' + , GmLogLevel(..) + , GhcModLog(..) + , GhcModError(..) + , GmEnv(..) + , GmState(..) + , GmLog(..) + , cradle + , options + , withOptions + , getCompilerMode + , setCompilerMode + -- ** Re-exporting convenient stuff + , MonadIO + , liftIO + ) where +-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. +-- RWST does not automatically become an instance of MonadIO. +-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. +-- So, RWST automatically becomes an instance of #if __GLASGOW_HASKELL__ < 708 -- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different -- classes before ghc 7.8 @@ -33,37 +65,28 @@ module Language.Haskell.GhcMod.Monad.Types where #endif import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Error import GHC import DynFlags -import GhcMonad hiding (withTempSession) -#if __GLASGOW_HASKELL__ <= 702 +import Exception import HscTypes -#endif --- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. --- RWST does not automatically become an instance of MonadIO. --- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. --- So, RWST automatically becomes an instance of MonadIO. -import MonadUtils +import Control.Applicative (Applicative, Alternative, (<$>)) +import Control.Monad -import Control.Applicative (Alternative) -import Control.Monad (MonadPlus) -import Control.Monad.Error (ErrorT) -import Control.Monad.Reader (ReaderT) -import Control.Monad.State.Strict (StateT) +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.Error (ErrorT(..), MonadError(..)) +import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Trans.Journal (JournalT) -import Control.Monad.Base (MonadBase, liftBase) -import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, - control, liftBaseOp, liftBaseOp_) +import Control.Monad.Base (MonadBase(..), liftBase) +import Control.Monad.Trans.Control -import Control.Monad.Trans.Class import Control.Monad.Reader.Class -import Control.Monad.Writer.Class (MonadWriter) +import Control.Monad.Writer.Class import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Journal.Class (MonadJournal(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) #ifdef MONADIO_INSTANCES import Control.Monad.Trans.Maybe (MaybeT) @@ -71,41 +94,49 @@ import Control.Monad.Error (Error(..)) #endif #if DIFFERENT_MONADIO -import Control.Monad.Trans.Class (lift) import qualified Control.Monad.IO.Class import Data.Monoid (Monoid) #endif -#if !MIN_VERSION_monad_control(1,0,0) -import Control.Monad (liftM) -#endif - +import Data.Set (Set) +import Data.Map (Map, empty) +import Data.Maybe import Data.Monoid import Data.IORef +import MonadUtils (MonadIO(..)) + data GhcModEnv = GhcModEnv { - gmGhcSession :: !(IORef HscEnv) - , gmOptions :: Options + gmOptions :: Options , gmCradle :: Cradle } data GhcModLog = GhcModLog { - gmLogMessages :: [String] + gmLogLevel :: Maybe GmLogLevel, + gmLogMessages :: [(GmLogLevel, String, String)] } deriving (Eq, Show, Read) instance Monoid GhcModLog where - mempty = GhcModLog mempty - GhcModLog a `mappend` GhcModLog b = GhcModLog (a `mappend` b) + mempty = GhcModLog (Just GmPanic) mempty + GhcModLog ml a `mappend` GhcModLog ml' b = + GhcModLog (ml' `mplus` ml) (a `mappend` b) + +data GmGhcSession = GmGhcSession { + gmgsOptions :: ![GHCOption], + gmgsSession :: !(IORef HscEnv) + } data GhcModState = GhcModState { - gmCompilerMode :: CompilerMode - } deriving (Eq,Show,Read) + gmGhcSession :: !(Maybe GmGhcSession) + , gmComponents :: !(Map GmComponentName (GmComponent (Set ModulePath))) + , gmCompilerMode :: !CompilerMode + } + +defaultGhcModState :: GhcModState +defaultGhcModState = GhcModState Nothing empty Simple data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read) -defaultState :: GhcModState -defaultState = GhcModState Simple - ---------------------------------------------------------------- -- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT' @@ -130,39 +161,111 @@ newtype GhcModT m a = GhcModT { #if DIFFERENT_MONADIO , Control.Monad.IO.Class.MonadIO #endif - , MonadReader GhcModEnv -- TODO: make MonadReader instance - -- pass-through like MonadState - , MonadWriter w , MonadError GhcModError ) +newtype GmLoadedT m a = GmLoadedT { unGmLoadedT :: GhcModT m a } + deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadTrans + , MonadIO +#if DIFFERENT_MONADIO + , Control.Monad.IO.Class.MonadIO +#endif + , MonadError GhcModError + , GmEnv + , GmState + , GmLog + ) + +newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a } + deriving ( Functor + , Applicative + , Monad + , MonadIO +#if DIFFERENT_MONADIO + , Control.Monad.IO.Class.MonadIO +#endif + ) + + +class Monad m => GmEnv m where + gmeAsk :: m GhcModEnv + gmeAsk = gmeReader id + + gmeReader :: (GhcModEnv -> a) -> m a + gmeReader f = f `liftM` gmeAsk + + gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a + {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-} + +instance Monad m => GmEnv (GhcModT m) where + gmeAsk = GhcModT ask + gmeReader = GhcModT . reader + gmeLocal f a = GhcModT $ local f (unGhcModT a) + +instance GmEnv m => GmEnv (StateT s m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f (StateT a) = StateT $ \s -> gmeLocal f (a s) + +class Monad m => GmState m where + gmsGet :: m GhcModState + gmsGet = gmsState (\s -> (s, s)) + + gmsPut :: GhcModState -> m () + gmsPut s = gmsState (\_ -> ((), s)) + + gmsState :: (GhcModState -> (a, GhcModState)) -> m a + gmsState f = do + s <- gmsGet + let ~(a, s') = f s + gmsPut s' + return a + {-# MINIMAL gmsState | gmsGet, gmsPut #-} + +instance Monad m => GmState (StateT GhcModState m) where + gmsGet = get + gmsPut = put + gmsState = state + +instance Monad m => GmState (GhcModT m) where + gmsGet = GhcModT get + gmsPut = GhcModT . put + gmsState = GhcModT . state + +class Monad m => GmLog m where + gmlJournal :: GhcModLog -> m () + gmlHistory :: m GhcModLog + gmlClear :: m () + +instance Monad m => GmLog (JournalT GhcModLog m) where + gmlJournal = journal + gmlHistory = history + gmlClear = clear + +instance Monad m => GmLog (GhcModT m) where + gmlJournal = GhcModT . lift . lift . journal + gmlHistory = GhcModT $ lift $ lift history + gmlClear = GhcModT $ lift $ lift clear + +instance (Monad m, GmLog m) => GmLog (ReaderT r m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +instance (Monad m, GmLog m) => GmLog (StateT s m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + instance MonadIO m => MonadIO (GhcModT m) where - liftIO action = do - res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action - case res of - Right a -> return a + liftIO action = GhcModT $ liftIO action - Left e | isIOError e -> - throwError $ GMEIOException (fromEx e :: IOError) - Left e | isGhcModError e -> - throwError $ (fromEx e :: GhcModError) - Left e -> throw e - - where - fromEx :: Exception e => SomeException -> e - fromEx se = let Just e = fromException se in e - - isIOError se = - case fromException se of - Just (_ :: IOError) -> True - Nothing -> False - - isGhcModError se = - case fromException se of - Just (_ :: GhcModError) -> True - Nothing -> False - -instance (Monad m) => MonadJournal GhcModLog (GhcModT m) where +instance Monad m => MonadJournal GhcModLog (GhcModT m) where journal !w = GhcModT $ lift $ lift $ (journal w) history = GhcModT $ lift $ lift $ history clear = GhcModT $ lift $ lift $ clear @@ -170,6 +273,18 @@ instance (Monad m) => MonadJournal GhcModLog (GhcModT m) where instance MonadTrans GhcModT where lift = GhcModT . lift . lift . lift . lift +instance forall r m. MonadReader r m => MonadReader r (GhcModT m) where + local f ma = gmLiftWithInner (\run -> local f (run ma)) + ask = gmLiftInner ask + +instance (Monoid w, MonadWriter w m) => MonadWriter w (GhcModT m) where + tell = gmLiftInner . tell + listen ma = + liftWith (\run -> listen (run ma)) >>= \(sta, w) -> + flip (,) w `liftM` restoreT (return sta) + + pass maww = maww >>= gmLiftInner . pass . return + instance MonadState s m => MonadState s (GhcModT m) where get = GhcModT $ lift $ lift $ lift get put = GhcModT . lift . lift . lift . put @@ -192,12 +307,24 @@ instance MonadIO m => MonadIO (MaybeT m) where liftIO = lift . liftIO #endif +instance (MonadBaseControl IO m) => MonadBase IO (GmLoadedT m) where + liftBase = GmLoadedT . liftBase + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GmLoadedT m) where + type StM (GmLoadedT m) a = StM (GhcModT m) a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadTransControl GmLoadedT where + type StT GmLoadedT a = StT GhcModT a + liftWith = defaultLiftWith GmLoadedT unGmLoadedT + restoreT = defaultRestoreT GmLoadedT instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where liftBase = GhcModT . liftBase -#if MIN_VERSION_monad_control(1,0,0) - instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where type StM (GhcModT m) a = StM (StateT GhcModState @@ -211,94 +338,109 @@ instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} -#else +instance MonadTransControl GhcModT where + type StT GhcModT a = (Either GhcModError (a, GhcModState), GhcModLog) -instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where - newtype StM (GhcModT m) a = StGhcMod { - unStGhcMod :: StM (StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) ) a } - liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> - f $ liftM StGhcMod . runInBase . unGhcModT + liftWith f = GhcModT $ + liftWith $ \runS -> + liftWith $ \runE -> + liftWith $ \runJ -> + liftWith $ \runR -> + f $ \ma -> runR $ runJ $ runE $ runS $ unGhcModT ma + restoreT = GhcModT . restoreT . restoreT . restoreT . restoreT + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} - restoreM = GhcModT . restoreM . unStGhcMod - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} +gmLiftInner :: Monad m => m a -> GhcModT m a +gmLiftInner = GhcModT . lift . lift . lift . lift -#endif +gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m)) + => (Run t -> m (StT t a)) -> t m a +gmLiftWithInner f = liftWith f >>= restoreT . return -- GHC cannot prove the following instances to be decidable automatically using -- the FlexibleContexts extension as they violate the second Paterson Condition, -- namely that: The assertion has fewer constructors and variables (taken -- together and counting repetitions) than the head. Specifically the --- @MonadBaseControl IO m@ constraint is causing this violation. --- --- Proof of termination: --- --- Assuming all constraints containing the variable `m' exist and are decidable --- we show termination by manually replacing the current set of constraints with --- their own set of constraints and show that this, after a finite number of --- steps, results in the empty set, i.e. not having to check any more --- constraints. --- --- We start by setting the constraints to be those immediate constraints of the --- instance declaration which cannot be proven decidable automatically for the --- type under consideration. --- --- @ --- { MonadBaseControl IO m } --- @ --- --- Classes used: --- --- * @class MonadBase b m => MonadBaseControl b m@ --- --- @ --- { MonadBase IO m } --- @ --- --- Classes used: --- --- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@ --- --- @ --- { Applicative IO, Applicative m, Monad IO, Monad m } --- @ --- --- Classes used: --- --- * @class Monad m@ --- * @class Applicative f => Functor f@ --- --- @ --- { Functor m } --- @ --- --- Classes used: --- --- * @class Functor f@ --- --- @ --- { } --- @ --- ∎ +-- @MonadBaseControl IO m@ constraint in 'IOish' is causing this violation. -instance (Functor m, MonadIO m, MonadBaseControl IO m) - => GhcMonad (GhcModT m) where - getSession = (liftIO . readIORef) . gmGhcSession =<< ask - setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask +type GmGhc m = (IOish m, GhcMonad m) + +instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmLoadedT m) where + getSession = do + ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet + liftIO $ readIORef ref + setSession a = do + ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet + liftIO $ flip writeIORef a ref + +instance GhcMonad LightGhc where + getSession = (liftIO . readIORef) =<< LightGhc ask + setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask #if __GLASGOW_HASKELL__ >= 706 -instance (Functor m, MonadIO m, MonadBaseControl IO m) - => HasDynFlags (GhcModT m) where - getDynFlags = getSessionDynFlags +instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmLoadedT m) where + getDynFlags = hsc_dflags <$> getSession + +instance HasDynFlags LightGhc where + getDynFlags = hsc_dflags <$> getSession #endif -instance (MonadIO m, MonadBaseControl IO m) - => ExceptionMonad (GhcModT m) where +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GhcModT m) where gcatch act handler = control $ \run -> run act `gcatch` (run . handler) gmask = liftBaseOp gmask . liftRestore where liftRestore f r = f $ liftBaseOp_ r + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmLoadedT m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance ExceptionMonad LightGhc where + gcatch act handl = + LightGhc $ unLightGhc act `gcatch` \e -> unLightGhc (handl e) + gmask f = + LightGhc $ gmask $ \io_restore ->let + g_restore (LightGhc m) = LightGhc $ io_restore m + in + unLightGhc (f g_restore) + + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (StateT s m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (ReaderT s m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +---------------------------------------------------------------- + +options :: GmEnv m => m Options +options = gmOptions `liftM` gmeAsk + +cradle :: GmEnv m => m Cradle +cradle = gmCradle `liftM` gmeAsk + +getCompilerMode :: GmState m => m CompilerMode +getCompilerMode = gmCompilerMode `liftM` gmsGet + +setCompilerMode :: GmState m => CompilerMode -> m () +setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet + +withOptions :: GmEnv m => (Options -> Options) -> m a -> m a +withOptions changeOpt action = gmeLocal changeEnv action + where + changeEnv e = e { gmOptions = changeOpt opt } + where + opt = gmOptions e diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index e569360..818a955 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns, TupleSections #-} -- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- @@ -20,28 +19,79 @@ module Language.Haskell.GhcMod.PathsAndFiles where import Config (cProjectVersion) import Control.Applicative import Control.Monad +import Control.Monad.Trans.Maybe import Data.List import Data.Char import Data.Maybe import Data.Traversable (traverse) -import Distribution.System (buildPlatform) -import Distribution.Text (display) -import Language.Haskell.GhcMod.Types +import Types import System.Directory import System.FilePath +import System.IO.Unsafe +import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.Read +import Language.Haskell.GhcMod.Utils hiding (dropWhileEnd) import qualified Language.Haskell.GhcMod.Utils as U -import Distribution.Simple.BuildPaths (defaultDistPref) -import Distribution.Simple.Configure (localBuildInfoFile) - -- | Guaranteed to be a path to a directory with no trailing slash. type DirPath = FilePath -- | Guaranteed to be the name of a file only (no slashes). type FileName = String +data Cached d a = Cached { + inputFiles :: [FilePath], + inputData :: d, + cacheFile :: FilePath + } + +newtype UnString = UnString { unString :: String } + +instance Show UnString where + show = unString + +instance Read UnString where + readsPrec _ = \str -> [(UnString str, "")] + +-- | +-- +-- >>> any (Just 3 <) [Just 1, Nothing, Just 2] +-- False +-- +-- >>> any (Just 0 <) [Just 1, Nothing, Just 2] +-- True +-- +-- >>> any (Just 0 <) [Nothing] +-- False +-- +-- >>> any (Just 0 <) [] +-- False +cached :: forall a d. (Read a, Show a, Eq d, Read d, Show d) + => DirPath -> Cached d a -> IO a -> IO a +cached dir Cached {..} ma = do + ins <- (maybeTimeFile . (dir )) `mapM` inputFiles + c <- maybeTimeFile (dir cacheFile) + if any (c<) ins || isNothing c + then writeCache + else maybe ma return =<< readCache + where + maybeTimeFile :: FilePath -> IO (Maybe TimedFile) + maybeTimeFile f = traverse timeFile =<< mightExist f + + writeCache = do + a <- ma + writeFile (dir cacheFile) $ unlines [show inputData, show a] + return a + + readCache :: IO (Maybe a) + readCache = runMaybeT $ do + hdr:c:_ <- lines <$> liftIO (readFile $ dir cacheFile) + if inputData /= read hdr + then liftIO $ writeCache + else MaybeT $ return $ readMaybe c + -- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent -- directories. The first parent directory containing more than one cabal file -- is assumed to be the project directory. If only one cabal file exists in this @@ -49,13 +99,17 @@ type FileName = String -- or 'GMETooManyCabalFiles' findCabalFile :: FilePath -> IO (Maybe FilePath) findCabalFile dir = do - dcs <- findFileInParentsP isCabalFile dir - -- Extract first non-empty list, which represents a directory with cabal - -- files. - case find (not . null) $ uncurry appendDir `map` dcs of - Just [] -> throw $ GMENoCabalFile + -- List of directories and all cabal file candidates + dcs <- findFileInParentsP isCabalFile dir :: IO ([(DirPath, [FileName])]) + let css = uncurry appendDir `map` dcs :: [[FilePath]] + case find (not . null) css of + Nothing -> return Nothing Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs - a -> return $ head <$> a + Just (a:_) -> return (Just a) + Just [] -> error "findCabalFile" + where + appendDir :: DirPath -> [FileName] -> [FilePath] + appendDir d fs = (d ) `map` fs -- | -- >>> isCabalFile "/home/user/.cabal" @@ -105,11 +159,8 @@ findCabalSandboxDir dir = do where isSandboxConfig = (=="cabal.sandbox.config") -appendDir :: DirPath -> [FileName] -> [FilePath] -appendDir d fs = (d ) `map` fs - zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)] -zipMapM f as = mapM (\a -> liftM (a,) $ f a) as +zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as -- | @parents dir@. Returns all parent directories of @dir@ including @dir@. -- @@ -169,24 +220,29 @@ setupConfigFile crdl = cradleRootDir crdl setupConfigPath -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ setupConfigPath :: FilePath -setupConfigPath = localBuildInfoFile defaultDistPref +setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref ghcSandboxPkgDbDir :: String ghcSandboxPkgDbDir = - targetPlatform ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d" - where - targetPlatform = display buildPlatform + cabalBuildPlatform ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d" + +cabalBuildPlatform :: String +cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $ + readLibExecProcess' "cabal-helper-wrapper" ["print-build-platform"] packageCache :: String packageCache = "package.cache" --- | Filename of the show'ed Cabal setup-config cache -prettyConfigCache :: FilePath -prettyConfigCache = setupConfigPath <.> "ghc-mod-0.pretty-cabal-cache" +cabalHelperCache :: [String] -> Cached [String] [Maybe GmCabalHelperResponse] +cabalHelperCache cmds = Cached { + inputFiles = [setupConfigPath], + inputData = cmds, + cacheFile = setupConfigPath <.> "ghc-mod.cabal-helper" + } -- | Filename of the symbol table cache file. symbolCache :: Cradle -> FilePath symbolCache crdl = cradleTempDir crdl symbolCacheFile symbolCacheFile :: String -symbolCacheFile = "ghc-mod-0.symbol-cache" +symbolCacheFile = "ghc-mod.symbol-cache" diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs index d981ddd..8497fcc 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ b/Language/Haskell/GhcMod/PkgDoc.hs @@ -11,11 +11,11 @@ import Control.Applicative ((<$>)) pkgDoc :: IOish m => String -> GhcModT m String pkgDoc mdl = do c <- cradle - pkg <- trim <$> readProcess' "ghc-pkg" (toModuleOpts c) + pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts c) "" if pkg == "" then return "\n" else do - htmlpath <- readProcess' "ghc-pkg" (toDocDirOpts pkg c) + htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg c) "" let ret = pkg ++ " " ++ drop 14 htmlpath return ret where diff --git a/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs new file mode 100644 index 0000000..7a023bd --- /dev/null +++ b/Language/Haskell/GhcMod/Pretty.hs @@ -0,0 +1,64 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +module Language.Haskell.GhcMod.Pretty where + +import Control.Arrow hiding ((<+>)) +import Text.PrettyPrint + +import Language.Haskell.GhcMod.Types + +docStyle :: Style +docStyle = style { ribbonsPerLine = 1.2 } + +gmRenderDoc :: Doc -> String +gmRenderDoc = renderStyle docStyle + +gmComponentNameDoc :: GmComponentName -> Doc +gmComponentNameDoc GmSetupHsName = text $ "Setup.hs" +gmComponentNameDoc GmLibName = text $ "library" +gmComponentNameDoc (GmExeName n) = text $ "exe:" ++ n +gmComponentNameDoc (GmTestName n) = text $ "test:" ++ n +gmComponentNameDoc (GmBenchName n) = text $ "bench:" ++ n + +gmLogLevelDoc :: GmLogLevel -> Doc +gmLogLevelDoc GmPanic = text "PANIC" +gmLogLevelDoc GmException = text "EXCEPTION" +gmLogLevelDoc GmError = text "ERROR" +gmLogLevelDoc GmWarning = text "Warning" +gmLogLevelDoc GmInfo = text "info" +gmLogLevelDoc GmDebug = text "DEBUG" + +infixl 6 <+>: +(<+>:) :: Doc -> Doc -> Doc +a <+>: b = (a <> colon) <+> b + +fnDoc :: FilePath -> Doc +fnDoc = doubleQuotes . text + +showDoc :: Show a => a -> Doc +showDoc = text . show + +warnDoc :: Doc -> Doc +warnDoc d = text "Warning" <+>: d + +strDoc :: String -> Doc +strDoc str = doc str + where + doc :: String -> Doc + doc = lines + >>> map (words >>> map text >>> fsep) + >>> \l -> case l of (x:xs) -> hang x 4 (vcat xs); [] -> empty diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index 87b4840..de398dd 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -13,12 +13,9 @@ import qualified GHC as G import GHC.SYB.Utils (Stage(..), everythingStaged) import GhcMonad import qualified Language.Haskell.Exts.Annotated as HE -import Language.Haskell.GhcMod.Doc (showOneLine, getStyle) -import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors) +import Language.Haskell.GhcMod.Doc +import Language.Haskell.GhcMod.Gap import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Monad (IOish, GhcModT) -import Language.Haskell.GhcMod.Target (setTargetFiles) import OccName (OccName) import Outputable (PprStyle) import TcHsSyn (hsPatType) @@ -83,22 +80,6 @@ typeSigInRangeHE _ _ _= False pretty :: DynFlags -> PprStyle -> Type -> String pretty dflag style = showOneLine dflag style . Gap.typeForUser ----------------------------------------------------------------- - -inModuleContext :: IOish m - => FilePath - -> (DynFlags -> PprStyle -> GhcModT m a) - -> GhcModT m a -inModuleContext file action = - withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWarningFlags) $ do - setTargetFiles [file] - Gap.withContext $ do - dflag <- G.getSessionDynFlags - style <- getStyle - action dflag style - ----------------------------------------------------------------- - showName :: DynFlags -> PprStyle -> G.Name -> String showName dflag style name = showOneLine dflag style $ Gap.nameForUser name diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 75d3d3b..51a3ba4 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE CPP #-} -module Language.Haskell.GhcMod.Target ( - setTargetFiles - ) where -- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- @@ -18,56 +14,319 @@ module Language.Haskell.GhcMod.Target ( -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-} +module Language.Haskell.GhcMod.Target where + +import Control.Arrow import Control.Applicative ((<$>)) -import Control.Monad (forM, void, (>=>)) -import DynFlags (ExtensionFlag(..), xopt) -import GHC (LoadHowMuch(..)) -import qualified GHC as G +import Control.Monad.Reader (runReaderT) +import GHC +import GHC.Paths (libdir) +import StaticFlags +import SysTools +import DynFlags +import HscMain +import HscTypes + import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.CabalHelper +import Language.Haskell.GhcMod.HomeModuleGraph +import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.Logging +import Language.Haskell.GhcMod.Types + +import Data.Maybe +import Data.Either +import Data.Foldable (foldrM) +import Data.IORef +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set + +import System.Directory +import System.FilePath + +withLightHscEnv :: forall m a. IOish m + => [GHCOption] -> (HscEnv -> m a) -> m a +withLightHscEnv opts action = gbracket initEnv teardownEnv (action) + + where + teardownEnv :: HscEnv -> m () + teardownEnv env = liftIO $ do + let dflags = hsc_dflags env + cleanTempFiles dflags + cleanTempDirs dflags + + initEnv :: m HscEnv + initEnv = liftIO $ do + initStaticOpts + settings <- initSysTools (Just libdir) + dflags <- initDynFlags (defaultDynFlags settings) + env <- newHscEnv dflags + dflags' <- runLightGhc env $ do + -- HomeModuleGraph and probably all other clients get into all sorts of + -- trouble if the package state isn't initialized here + _ <- setSessionDynFlags =<< getSessionDynFlags + addCmdOpts opts =<< getSessionDynFlags + newHscEnv dflags' + +runLightGhc :: HscEnv -> LightGhc a -> IO a +runLightGhc env action = do + renv <- newIORef env + flip runReaderT renv $ unLightGhc action + +runGmPkgGhc :: (IOish m, GmEnv m) => LightGhc a -> m a +runGmPkgGhc action = do + pkgOpts <- packageGhcOptions + withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action + +initSession :: IOish m + => [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m () +initSession opts mdf = do + s <- gmsGet + case gmGhcSession s of + Just GmGhcSession {..} -> do + if gmgsOptions == opts + then return () + else error "TODO: reload stuff" + Nothing -> do + Cradle { cradleTempDir } <- cradle + ghc <- liftIO $ runGhc (Just libdir) $ do + let setDf df = + setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df) + _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags + getSession + + rghc <- liftIO $ newIORef ghc + gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc } + + +-- $ do +-- dflags <- getSessionDynFlags +-- defaultCleanupHandler dflags $ do +-- initializeFlagsWithCradle opt (gmCradle env) +-- + +-- initSession :: GhcMonad m => Options -> [GHCOption] -> m () +-- initSession Options {..} ghcOpts = do +-- df <- G.getSessionDynFlags +-- void $ +-- ( setModeSimple -- $ setEmptyLogger +-- df) + +runGmLoadedT :: IOish m + => [Either FilePath ModuleName] -> GmLoadedT m a -> GhcModT m a +runGmLoadedT fns action = runGmLoadedT' fns return action + +runGmLoadedT' :: IOish m + => [Either FilePath ModuleName] + -> (DynFlags -> Ghc DynFlags) + -> GmLoadedT m a + -> GhcModT m a +runGmLoadedT' fns mdf action = runGmLoadedTWith fns mdf id action + +runGmLoadedTWith :: IOish m + => [Either FilePath ModuleName] + -> (DynFlags -> Ghc DynFlags) + -> (GmLoadedT m a -> GmLoadedT m b) + -> GmLoadedT m a + -> GhcModT m b +runGmLoadedTWith efnmns' mdf wrapper action = do + crdl <- cradle + Options { ghcUserOptions } <- options + + let (fns, mns) = partitionEithers efnmns' + ccfns = map (cradleCurrentDir crdl ) fns + cfns <- liftIO $ mapM canonicalizePath ccfns + let rfns = map (makeRelative $ cradleRootDir crdl) cfns + serfnmn = Set.fromList $ map Right mns ++ map Left rfns + + opts <- targetGhcOptions crdl serfnmn + let opts' = opts ++ ghcUserOptions + + initSession opts' $ + setModeSimple >>> setEmptyLogger >>> mdf + + unGmLoadedT $ wrapper $ do + loadTargets (map moduleNameString mns ++ rfns) + action + +targetGhcOptions :: IOish m + => Cradle + -> Set (Either FilePath ModuleName) + -> GhcModT m [GHCOption] +targetGhcOptions crdl sefnmn = do + when (Set.null sefnmn) $ error "targetGhcOptions: no targets given" + + case cradleCabalFile crdl of + Just _ -> cabalOpts + Nothing -> sandboxOpts crdl + where + zipMap f l = l `zip` (f `map` l) + cabalOpts = do + mcs <- resolveGmComponents Nothing =<< getComponents + + let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn + candidates = Set.unions $ map snd mdlcs + + when (Set.null candidates) $ + throwError $ GMECabalCompAssignment mdlcs + + let cn = pickComponent candidates + return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs + +moduleComponents :: Map GmComponentName (GmComponent (Set ModulePath)) + -> Either FilePath ModuleName + -> Set GmComponentName +moduleComponents m efnmn = + foldr' Set.empty m $ \c s -> + let + memb = + case efnmn of + Left fn -> fn `Set.member` Set.map mpPath (smp c) + Right mn -> mn `Set.member` Set.map mpModule (smp c) + in if memb + then Set.insert (gmcName c) s + else s + where + smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c + + foldr' b as f = Map.foldr f b as + +pickComponent :: Set GmComponentName -> GmComponentName +pickComponent scn = Set.findMin scn + + +packageGhcOptions :: (MonadIO m, GmEnv m) => m [GHCOption] +packageGhcOptions = do + crdl <- cradle + case cradleCabalFile crdl of + Just _ -> do + (Set.toList . Set.fromList . concat . map snd) `liftM` getGhcPkgOptions + Nothing -> sandboxOpts crdl + +sandboxOpts :: Monad m => Cradle -> m [String] +sandboxOpts crdl = return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts + where + pkgOpts = ghcDbStackOpts $ cradlePkgDbStack crdl + (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl) + +resolveGmComponent :: (IOish m, GmLog m, GmEnv m) + => Maybe [Either FilePath ModuleName] -- ^ Updated modules + -> GmComponent (Either FilePath [ModuleName]) + -> m (GmComponent (Set ModulePath)) +resolveGmComponent mums c@GmComponent {..} = + withLightHscEnv gmcGhcSrcOpts $ \env -> do + let srcDirs = gmcSourceDirs + mg = gmcHomeModuleGraph + + let eps = either (return . Left) (map Right) gmcEntrypoints + simp <- liftIO $ resolveEntrypoints env srcDirs eps + sump <- liftIO $ case mums of + Nothing -> return simp + Just ums -> resolveEntrypoints env srcDirs ums + + mg' <- updateHomeModuleGraph env mg simp sump + + return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' } + +resolveEntrypoints :: MonadIO m + => HscEnv -> [FilePath] -> [Either FilePath ModuleName] -> m (Set ModulePath) +resolveEntrypoints env srcDirs ms = + liftIO $ Set.fromList . catMaybes <$> resolve `mapM` ms + where + resolve :: Either FilePath ModuleName -> IO (Maybe ModulePath) + resolve (Right mn) = findModulePath env mn + resolve (Left fn') = do + mfn <- findFile srcDirs fn' + case mfn of + Nothing -> return Nothing + Just fn'' -> do + let fn = normalise fn'' + emn <- fileModuleName env fn + return $ case emn of + Left _ -> Nothing + Right mmn -> Just $ + case mmn of + Nothing -> mkMainModulePath fn + Just mn -> ModulePath mn fn + +resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m) + => Maybe [Either FilePath ModuleName] + -- ^ Updated modules + -> [GmComponent (Either FilePath [ModuleName])] + -> m (Map GmComponentName (GmComponent (Set ModulePath))) +resolveGmComponents mumns cs = do + s <- gmsGet + m' <- foldrM' (gmComponents s) cs $ \c m -> do + case Map.lookup (gmcName c) m of + Nothing -> insertUpdated m c + Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c' + then return m + else insertUpdated m c + gmsPut s { gmComponents = m' } + return m' + + where + foldrM' b fa f = foldrM f b fa + insertUpdated m c = do + rc <- resolveGmComponent mumns c + return $ Map.insert (gmcName rc) rc m + + same :: Eq b + => (forall a. GmComponent a -> b) + -> GmComponent c -> GmComponent d -> Bool + same f a b = (f a) == (f b) + -- | Set the files as targets and load them. -setTargetFiles :: IOish m => [FilePath] -> GhcModT m () -setTargetFiles files = do - targets <- forM files $ \file -> G.guessTarget file Nothing - G.setTargets targets +loadTargets :: IOish m => [String] -> GmLoadedT m () +loadTargets filesOrModules = do + gmLog GmDebug "loadTargets" $ + text "Loading" <+>: fsep (map text filesOrModules) + + targets <- forM filesOrModules (flip guessTarget Nothing) + setTargets targets + mode <- getCompilerMode - if mode == Intelligent then - loadTargets Intelligent + if mode == Intelligent + then loadTargets' Intelligent else do - mdls <- G.depanal [] False + mdls <- depanal [] False let fallback = needsFallback mdls if fallback then do resetTargets targets setIntelligent - loadTargets Intelligent + gmLog GmInfo "loadTargets" $ + text "Switching to LinkInMemory/HscInterpreted (memory hungry)" + loadTargets' Intelligent else - loadTargets Simple + loadTargets' Simple where - loadTargets Simple = do - -- Reporting error A and error B - void $ G.load LoadAllTargets - mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph - -- Reporting error B and error C - mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss - -- Error B duplicates. But we cannot ignore both error reportings, - -- sigh. So, the logger makes log messages unique by itself. - loadTargets Intelligent = do - df <- G.getSessionDynFlags - void $ G.setSessionDynFlags (setModeIntelligent df) - void $ G.load LoadAllTargets + loadTargets' Simple = do + void $ load LoadAllTargets + + loadTargets' Intelligent = do + df <- getSessionDynFlags + void $ setSessionDynFlags (setModeIntelligent df) + void $ load LoadAllTargets + resetTargets targets = do - G.setTargets [] - void $ G.load LoadAllTargets - G.setTargets targets + setTargets [] + void $ load LoadAllTargets + setTargets targets + setIntelligent = do - newdf <- setModeIntelligent <$> G.getSessionDynFlags - void $ G.setSessionDynFlags newdf + newdf <- setModeIntelligent <$> getSessionDynFlags + void $ setSessionDynFlags newdf setCompilerMode Intelligent -needsFallback :: G.ModuleGraph -> Bool +needsFallback :: ModuleGraph -> Bool needsFallback = any $ \ms -> - let df = G.ms_hspp_opts ms in + let df = ms_hspp_opts ms in Opt_TemplateHaskell `xopt` df || Opt_QuasiQuotes `xopt` df #if __GLASGOW_HASKELL__ >= 708 diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 46b7a35..db71b60 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -1,13 +1,29 @@ -module Language.Haskell.GhcMod.Types where +{-# LANGUAGE DeriveDataTypeable, GADTs, StandaloneDeriving, DataKinds #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Language.Haskell.GhcMod.Types ( + module Language.Haskell.GhcMod.Types + , module Types + , ModuleName + , mkModuleName + , moduleNameString + ) where import Control.Monad.Trans.Control (MonadBaseControl) -import Data.List (intercalate) -import qualified Data.Map as M +import Control.Monad.Error (Error(..)) +import Control.Exception (Exception) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Monoid +import Data.Typeable (Typeable) import Exception (ExceptionMonad) import MonadUtils (MonadIO) - +import GHC (ModuleName, moduleNameString, mkModuleName) import PackageConfig (PackageConfig) +import Types + -- | A constraint alias (-XConstraintKinds) to make functions dealing with -- 'GhcModT' somewhat cleaner. -- @@ -28,8 +44,10 @@ data Options = Options { outputStyle :: OutputStyle -- | Line separator string. , lineSeparator :: LineSeparator - -- | @ghc@ program name. - , ghcProgram :: FilePath + -- | Verbosity + , logLevel :: GmLogLevel +-- -- | @ghc@ program name. +-- , ghcProgram :: FilePath -- | @cabal@ program name. , cabalProgram :: FilePath -- | GHC command line options set on the @ghc-mod@ command line @@ -48,14 +66,15 @@ data Options = Options { defaultOptions :: Options defaultOptions = Options { outputStyle = PlainStyle - , hlintOpts = [] - , ghcProgram = "ghc" + , lineSeparator = LineSeparator "\0" + , logLevel = GmPanic +-- , ghcProgram = "ghc" , cabalProgram = "cabal" , ghcUserOptions= [] , operators = False , detailed = False , qualified = False - , lineSeparator = LineSeparator "\0" + , hlintOpts = [] } ---------------------------------------------------------------- @@ -76,57 +95,110 @@ data Cradle = Cradle { ---------------------------------------------------------------- --- | GHC package database flags. -data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show) - --- | A single GHC command line option. -type GHCOption = String - --- | An include directory for modules. -type IncludeDir = FilePath - --- | A package name. -type PackageBaseName = String - --- | A package version. -type PackageVersion = String - --- | A package id. -type PackageId = String - --- | A package's name, verson and id. -type Package = (PackageBaseName, PackageVersion, PackageId) - -pkgName :: Package -> PackageBaseName -pkgName (n,_,_) = n - -pkgVer :: Package -> PackageVersion -pkgVer (_,v,_) = v - -pkgId :: Package -> PackageId -pkgId (_,_,i) = i - -showPkg :: Package -> String -showPkg (n,v,_) = intercalate "-" [n,v] - -showPkgId :: Package -> String -showPkgId (n,v,i) = intercalate "-" [n,v,i] +data GmLogLevel = GmPanic + | GmException + | GmError + | GmWarning + | GmInfo + | GmDebug + deriving (Eq, Ord, Enum, Bounded, Show, Read) -- | Collection of packages -type PkgDb = (M.Map Package PackageConfig) +type PkgDb = (Map Package PackageConfig) --- | Haskell expression. -type Expression = String +data GmModuleGraph = GmModuleGraph { + gmgFileMap :: Map FilePath ModulePath, + gmgModuleMap :: Map ModuleName ModulePath, + gmgGraph :: Map ModulePath (Set ModulePath) + } deriving (Eq, Ord, Show, Read, Typeable) --- | Module name. -type ModuleString = String +instance Monoid GmModuleGraph where + mempty = GmModuleGraph mempty mempty mempty + mappend (GmModuleGraph a b c) (GmModuleGraph a' b' c') = + GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c') --- | A Module -type Module = [String] +data GmComponent eps = GmComponent { + gmcName :: GmComponentName, + gmcGhcOpts :: [GHCOption], + gmcGhcSrcOpts :: [GHCOption], + gmcRawEntrypoints :: Either FilePath [ModuleName], + gmcEntrypoints :: eps, + gmcSourceDirs :: [FilePath], + gmcHomeModuleGraph :: GmModuleGraph + } deriving (Eq, Ord, Show, Read, Typeable) --- | Option information for GHC -data CompilerOptions = CompilerOptions { - ghcOptions :: [GHCOption] -- ^ Command line options - , includeDirs :: [IncludeDir] -- ^ Include directories for modules - , depPackages :: [Package] -- ^ Dependent package names - } deriving (Eq, Show) +data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath } + deriving (Eq, Ord, Show, Read, Typeable) + +instance Show ModuleName where + show mn = "ModuleName " ++ show (moduleNameString mn) + +instance Read ModuleName where + readsPrec d r = readParen (d > app_prec) + (\r' -> [(mkModuleName m,t) | + ("ModuleName",s) <- lex r', + (m,t) <- readsPrec (app_prec+1) s]) r + where app_prec = 10 + + +--- \ / These types MUST be in sync with the copies in cabal-helper/Main.hs +data GmComponentName = GmSetupHsName + | GmLibName + | GmExeName String + | GmTestName String + | GmBenchName String + deriving (Eq, Ord, Read, Show) +data GmCabalHelperResponse + = GmCabalHelperStrings [(GmComponentName, [String])] + | GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [ModuleName])] + | GmCabalHelperLbi String + deriving (Read, Show) +--- ^ These types MUST be in sync with the copies in cabal-helper/Main.hs + +data GhcModError + = GMENoMsg + -- ^ Unknown error + + | GMEString String + -- ^ Some Error with a message. These are produced mostly by + -- 'fail' calls on GhcModT. + + | GMECabalConfigure GhcModError + -- ^ Configuring a cabal project failed. + + | GMECabalFlags GhcModError + -- ^ Retrieval of the cabal configuration flags failed. + + | GMECabalComponent GmComponentName + -- ^ Cabal component could not be found + + | GMECabalCompAssignment [(Either FilePath ModuleName, Set GmComponentName)] + -- ^ Could not find a consistent component assignment for modules + + | GMEProcess String [String] (Either (String, String, Int) GhcModError) + -- ^ Launching an operating system process failed. Fields in + -- order: command, arguments, (stdout, stderr, exitcode) + + | GMENoCabalFile + -- ^ No cabal file found. + + | GMETooManyCabalFiles [FilePath] + -- ^ Too many cabal files found. + + | GMECabalStateFile GMConfigStateFileError + -- ^ Reading Cabal's state configuration file falied somehow. + deriving (Eq,Show,Typeable) + +instance Error GhcModError where + noMsg = GMENoMsg + strMsg = GMEString + +instance Exception GhcModError + +data GMConfigStateFileError + = GMConfigStateFileNoHeader + | GMConfigStateFileBadHeader + | GMConfigStateFileNoParse + | GMConfigStateFileMissing +-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) + deriving (Eq, Show, Read, Typeable) diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 7574bbb..7aafc69 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -15,28 +15,28 @@ -- along with this program. If not, see . {-# LANGUAGE CPP #-} -module Language.Haskell.GhcMod.Utils where +module Language.Haskell.GhcMod.Utils ( + module Language.Haskell.GhcMod.Utils + , module Utils + , readProcess + ) where import Control.Arrow -import Control.Applicative ((<$>)) +import Control.Applicative import Data.Char import Language.Haskell.GhcMod.Error -import MonadUtils (MonadIO, liftIO) +import Exception import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist) -import System.Exit (ExitCode(..)) -import System.Process (readProcessWithExitCode) +import System.Process (readProcess) import System.Directory (getTemporaryDirectory) -import System.FilePath (splitDrive, pathSeparators, ()) +import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators, + ()) import System.IO.Temp (createTempDirectory) -#ifndef SPEC -import Paths_ghc_mod (getLibexecDir) import System.Environment -import System.FilePath (takeDirectory) -#else --- When compiling test suite -import Data.IORef -import System.IO.Unsafe -#endif +import Text.Printf + +import Paths_ghc_mod (getLibexecDir) +import Utils -- dropWhileEnd is not provided prior to base 4.5.0.0. dropWhileEnd :: (a -> Bool) -> [a] -> [a] @@ -54,21 +54,6 @@ extractParens str = extractParens' str 0 | s `elem` "}])" = s : extractParens' ss (level-1) | otherwise = s : extractParens' ss level -readProcess' :: (MonadIO m, GmError m) - => String - -> [String] - -> m String -readProcess' cmd opts = do - (rv,output,err) <- liftIO (readProcessWithExitCode cmd opts "") - `modifyError'` GMEProcess ([cmd] ++ opts) - case rv of - ExitFailure val -> do - throwError $ GMEProcess ([cmd] ++ opts) $ strMsg $ - cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")" - ++ "\n" ++ err - ExitSuccess -> - return output - withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a withDirectory_ dir action = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) @@ -91,42 +76,85 @@ newTempDir :: FilePath -> IO FilePath newTempDir dir = flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory -mightExist :: FilePath -> IO (Maybe FilePath) -mightExist f = do - exists <- doesFileExist f - return $ if exists then (Just f) else (Nothing) +whenM :: IO Bool -> IO () -> IO () +whenM mb ma = mb >>= flip when ma -- | Returns the path to the currently running ghc-mod executable. With ghc<7.6 -- this is a guess but >=7.6 uses 'getExecutablePath'. ghcModExecutable :: IO FilePath #ifndef SPEC ghcModExecutable = do - dir <- getExecutablePath' - return $ dir "ghc-mod" - where - getExecutablePath' :: IO FilePath -# if __GLASGOW_HASKELL__ >= 706 - getExecutablePath' = takeDirectory <$> getExecutablePath -# else - getExecutablePath' = return "" -# endif + dir <- takeDirectory <$> getExecutablePath' + return $ (if dir == "." then "" else dir) "ghc-mod" #else ghcModExecutable = fmap ( "dist/build/ghc-mod/ghc-mod") getCurrentDirectory #endif -#ifdef SPEC --- Ugly workaround :'( but I can't think of any other way of doing this --- the test suite changes the cwd often so I can't use relative paths :/ -specRootDir :: IORef FilePath -specRootDir = unsafePerformIO $ newIORef undefined -{-# NOINLINE specRootDir #-} -#endif - findLibexecExe :: String -> IO FilePath -#ifndef SPEC -findLibexecExe "cabal-helper" = (fmap ( "cabal-helper")) getLibexecDir -#else -findLibexecExe "cabal-helper" = - ( "dist/build/cabal-helper/cabal-helper") <$> (readIORef specRootDir) -#endif +findLibexecExe "cabal-helper-wrapper" = do + libexecdir <- getLibexecDir + let exeName = "cabal-helper-wrapper" + exe = libexecdir exeName + + exists <- doesFileExist exe + + if exists + then return exe + else do + mdir <- tryFindGhcModTreeDataDir + case mdir of + Nothing -> + error $ libexecNotExitsError exeName libexecdir + Just dir -> + return $ dir "dist" "build" exeName exeName findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe + +libexecNotExitsError :: String -> FilePath -> String +libexecNotExitsError exe dir = printf + ( "Could not find $libexecdir/%s\n" + ++"\n" + ++"If you are a developer set the environment variable `ghc_mod_libexecdir'\n" + ++"to override $libexecdir[1] the following will work in the ghc-mod tree:\n" + ++"\n" + ++" $ export ghc_mod_libexecdir=$PWD/dist/build/%s\n" + ++"\n" + ++"[1]: %s\n" + ++"\n" + ++"If you don't know what I'm talking about something went wrong with your\n" + ++"installation. Please report this problem here:\n" + ++"\n" + ++" https://github.com/kazu-yamamoto/ghc-mod/issues") exe exe dir + +tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath) +tryFindGhcModTreeLibexecDir = do + exe <- getExecutablePath + dir <- case takeFileName exe of + "ghc" -> do -- we're probably in ghci; try CWD + getCurrentDirectory + _ -> + return $ (!!4) $ iterate takeDirectory exe + exists <- doesFileExist $ dir "ghc-mod.cabal" + return $ if exists + then Just dir + else Nothing + +tryFindGhcModTreeDataDir :: IO (Maybe FilePath) +tryFindGhcModTreeDataDir = do + dir <- (!!4) . iterate takeDirectory <$> getExecutablePath' + exists <- doesFileExist $ dir "ghc-mod.cabal" + return $ if exists + then Just dir + else Nothing + +readLibExecProcess' :: (MonadIO m, ExceptionMonad m) + => String -> [String] -> m String +readLibExecProcess' cmd args = do + exe <- liftIO $ findLibexecExe cmd + liftIO $ readProcess exe args "" + +getExecutablePath' :: IO FilePath +#if __GLASGOW_HASKELL__ >= 706 +getExecutablePath' = getExecutablePath +#else +getExecutablePath' = getProgName +#endif diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs index 2779627..41035f3 100644 --- a/Language/Haskell/GhcMod/World.hs +++ b/Language/Haskell/GhcMod/World.hs @@ -1,82 +1,44 @@ -{-# LANGUAGE RecordWildCards, CPP #-} module Language.Haskell.GhcMod.World where -{-( - , World - , getCurrentWorld - , isWorldChanged - ) where --} import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils -import Control.Applicative (pure, (<$>), (<*>)) -import Control.Monad +import Control.Applicative ((<$>)) import Data.Maybe import Data.Traversable (traverse) -import System.Directory (getModificationTime) import System.FilePath (()) import GHC.Paths (libdir) -#if __GLASGOW_HASKELL__ <= 704 -import System.Time (ClockTime) -#else -import Data.Time (UTCTime) -#endif - - -#if __GLASGOW_HASKELL__ <= 704 -type ModTime = ClockTime -#else -type ModTime = UTCTime -#endif - -data TimedFile = TimedFile FilePath ModTime deriving (Eq, Show) - -instance Ord TimedFile where - compare (TimedFile _ a) (TimedFile _ b) = compare a b - -timeFile :: FilePath -> IO TimedFile -timeFile f = TimedFile <$> pure f <*> getModificationTime f - data World = World { worldPackageCaches :: [TimedFile] , worldCabalFile :: Maybe TimedFile , worldCabalConfig :: Maybe TimedFile , worldSymbolCache :: Maybe TimedFile - , worldPrettyCabalConfigCache :: Maybe TimedFile } deriving (Eq, Show) -timedPackageCache :: Cradle -> IO [TimedFile] -timedPackageCache crdl = do +timedPackageCaches :: Cradle -> IO [TimedFile] +timedPackageCaches crdl = do fs <- mapM mightExist . map ( packageCache) =<< getPackageCachePaths libdir crdl timeFile `mapM` catMaybes fs getCurrentWorld :: Cradle -> IO World getCurrentWorld crdl = do - pkgCaches <- timedPackageCache crdl + pkgCaches <- timedPackageCaches crdl mCabalFile <- timeFile `traverse` cradleCabalFile crdl mCabalConfig <- timeMaybe (setupConfigFile crdl) mSymbolCache <- timeMaybe (symbolCache crdl) - mPrettyConfigCache <- timeMaybe prettyConfigCache return World { worldPackageCaches = pkgCaches , worldCabalFile = mCabalFile , worldCabalConfig = mCabalConfig , worldSymbolCache = mSymbolCache - , worldPrettyCabalConfigCache = mPrettyConfigCache } - where - timeMaybe :: FilePath -> IO (Maybe TimedFile) - timeMaybe f = do - join $ (timeFile `traverse`) <$> mightExist f - didWorldChange :: World -> Cradle -> IO Bool didWorldChange world crdl = do (world /=) <$> getCurrentWorld crdl diff --git a/Utils.hs b/Utils.hs new file mode 100644 index 0000000..8c1d057 --- /dev/null +++ b/Utils.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP #-} +module Utils where + +import Control.Monad +import Control.Applicative +import Data.Traversable +import System.Directory + +#if MIN_VERSION_directory(1,2,0) +import Data.Time (UTCTime) +#else +import System.Time (ClockTime) +#endif + +#if MIN_VERSION_directory(1,2,0) +type ModTime = UTCTime +#else +type ModTime = ClockTime +#endif + +data TimedFile = TimedFile FilePath ModTime deriving (Eq, Show) + +instance Ord TimedFile where + compare (TimedFile _ a) (TimedFile _ b) = compare a b + +timeFile :: FilePath -> IO TimedFile +timeFile f = TimedFile <$> pure f <*> getModificationTime f + +mightExist :: FilePath -> IO (Maybe FilePath) +mightExist f = do + exists <- doesFileExist f + return $ if exists then (Just f) else (Nothing) + +timeMaybe :: FilePath -> IO (Maybe TimedFile) +timeMaybe f = do + join $ (timeFile `traverse`) <$> mightExist f diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 77e2217..b6dfa20 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -19,14 +19,15 @@ Description: The ghc-mod command is a backend command to enrich For more information, please see its home page. Category: Development -Cabal-Version: >= 1.10 +Cabal-Version: >= 1.16 Build-Type: Custom -Data-Dir: elisp -Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el - ghc-check.el ghc-process.el ghc-command.el ghc-info.el - ghc-ins-mod.el ghc-indent.el ghc-pkg.el ghc-rewrite.el +Data-Files: elisp/Makefile + elisp/*.el + cabal-helper/*.hs + Extra-Source-Files: ChangeLog SetupCompat.hs + NotCPP/*.hs test/data/*.cabal test/data/*.hs test/data/cabal.sandbox.config.in @@ -56,29 +57,23 @@ Extra-Source-Files: ChangeLog test/data/subdir1/subdir2/dummy test/data/.cabal-sandbox/packages/00-index.tar -Flag cabal-122 - Default: True - Manual: False - Library Default-Language: Haskell2010 - GHC-Options: -Wall - Default-Extensions: ConstraintKinds, FlexibleContexts + GHC-Options: -Wall -fno-warn-deprecations + Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, + ConstraintKinds, FlexibleContexts Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Internal Other-Modules: Paths_ghc_mod + Types + Utils Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Browse - Language.Haskell.GhcMod.CabalConfig.Cabal16 - Language.Haskell.GhcMod.CabalConfig.Cabal18 - Language.Haskell.GhcMod.CabalConfig.Cabal22 - Language.Haskell.GhcMod.CabalConfig.Extract - Language.Haskell.GhcMod.CabalConfig - Language.Haskell.GhcMod.CabalApi Language.Haskell.GhcMod.CaseSplit Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Convert Language.Haskell.GhcMod.Cradle + Language.Haskell.GhcMod.CabalHelper Language.Haskell.GhcMod.Debug Language.Haskell.GhcMod.Doc Language.Haskell.GhcMod.DynFlags @@ -86,9 +81,9 @@ Library Language.Haskell.GhcMod.FillSig Language.Haskell.GhcMod.Find Language.Haskell.GhcMod.Flag - Language.Haskell.GhcMod.GHCChoice Language.Haskell.GhcMod.Gap Language.Haskell.GhcMod.GhcPkg + Language.Haskell.GhcMod.HomeModuleGraph Language.Haskell.GhcMod.Info Language.Haskell.GhcMod.Lang Language.Haskell.GhcMod.Lint @@ -99,14 +94,13 @@ Library Language.Haskell.GhcMod.Monad.Types Language.Haskell.GhcMod.PathsAndFiles Language.Haskell.GhcMod.PkgDoc + Language.Haskell.GhcMod.Pretty Language.Haskell.GhcMod.Read Language.Haskell.GhcMod.SrcUtils Language.Haskell.GhcMod.Target Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.World - - Build-Depends: base >= 4.0 && < 5 , bytestring , containers @@ -117,7 +111,6 @@ Library , ghc-paths , ghc-syb-utils , hlint >= 1.8.61 - , io-choice , monad-journal >= 0.4 , old-time , pretty @@ -128,18 +121,13 @@ Library , transformers , transformers-base , mtl >= 2.0 - , monad-control + , monad-control >= 1 , split , haskell-src-exts , text , djinn-ghc >= 0.0.2.2 if impl(ghc < 7.8) Build-Depends: convertible - , Cabal >= 1.10 && < 1.17 - else - Build-Depends: Cabal >= 1.18 - if flag(cabal-122) - Build-Depends: Cabal >= 1.22 if impl(ghc <= 7.4.2) -- Only used to constrain random to a version that still works with GHC 7.4 Build-Depends: random <= 1.0.1.1 @@ -148,7 +136,7 @@ Executable ghc-mod Default-Language: Haskell2010 Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod - GHC-Options: -Wall + GHC-Options: -Wall -fno-warn-deprecations Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 @@ -169,7 +157,7 @@ Executable ghc-modi Other-Modules: Paths_ghc_mod Misc Utils - GHC-Options: -Wall -threaded + GHC-Options: -Wall -threaded -fno-warn-deprecations if os(windows) Cpp-Options: -DWINDOWS Default-Extensions: ConstraintKinds, FlexibleContexts @@ -218,16 +206,20 @@ Test-Suite doctest Test-Suite spec Default-Language: Haskell2010 - Default-Extensions: ConstraintKinds, FlexibleContexts + Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, + ConstraintKinds, FlexibleContexts, OverloadedStrings Main-Is: Main.hs Hs-Source-Dirs: test, . - Ghc-Options: -Wall + Ghc-Options: -Wall -fno-warn-deprecations CPP-Options: -DSPEC=1 Type: exitcode-stdio-1.0 - Other-Modules: BrowseSpec - CabalApiSpec - CheckSpec + Other-Modules: Paths_ghc_mod + Types Dir + Spec + TestUtils + BrowseSpec + CheckSpec FlagSpec InfoSpec LangSpec @@ -235,8 +227,7 @@ Test-Suite spec ListSpec MonadSpec PathsAndFilesSpec - Spec - TestUtils + HomeModuleGraphSpec Build-Depends: hspec if impl(ghc == 7.4.*) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 415a054..af8b356 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -259,8 +259,9 @@ reqArg udsc dsc = ReqArg dsc udsc globalArgSpec :: [OptDescr (Options -> Options)] globalArgSpec = - [ option "v" ["verbose"] "Be more verbose." $ - NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o } + [ option "v" ["verbose"] "Can be given multiple times to be increasingly\ + \more verbose." $ + NoArg $ \o -> o { logLevel = increaseLogLevel (logLevel o) } , option "l" ["tolisp"] "Format output as an S-Expression" $ NoArg $ \o -> o { outputStyle = LispStyle } @@ -272,8 +273,8 @@ globalArgSpec = reqArg "OPT" $ \g o -> o { ghcUserOptions = g : ghcUserOptions o } - , option "" ["with-ghc"] "GHC executable to use" $ - reqArg "PROG" $ \p o -> o { ghcProgram = p } +-- , option "" ["with-ghc"] "GHC executable to use" $ +-- reqArg "PROG" $ \p o -> o { ghcProgram = p } , option "" ["with-cabal"] "cabal-install executable to use" $ reqArg "PROG" $ \p o -> o { cabalProgram = p } From bc71877dcfbd43a1434ebc9840e4a176e29982ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 4 Mar 2015 16:45:26 +0100 Subject: [PATCH 020/207] Change the way cabal-helper is built a bit --- CabalHelper/Common.hs | 96 ++++++++++++ {cabal-helper => CabalHelper}/Main.hs | 55 +++---- CabalHelper/Types.hs | 18 +++ {cabal-helper => CabalHelper}/Wrapper.hs | 192 ++++++++++++++--------- Language/Haskell/GhcMod/CabalHelper.hs | 7 +- Language/Haskell/GhcMod/PathsAndFiles.hs | 1 - Language/Haskell/GhcMod/Types.hs | 66 ++++++-- cabal-helper/Common.hs | 41 ----- ghc-mod.cabal | 11 +- 9 files changed, 314 insertions(+), 173 deletions(-) create mode 100644 CabalHelper/Common.hs rename {cabal-helper => CabalHelper}/Main.hs (89%) create mode 100644 CabalHelper/Types.hs rename {cabal-helper => CabalHelper}/Wrapper.hs (55%) delete mode 100644 cabal-helper/Common.hs diff --git a/CabalHelper/Common.hs b/CabalHelper/Common.hs new file mode 100644 index 0000000..692b373 --- /dev/null +++ b/CabalHelper/Common.hs @@ -0,0 +1,96 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +module CabalHelper.Common where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Data.List +import Data.Maybe +import Data.Version +import Data.Typeable +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import System.Environment +import System.IO +import System.Exit +import Text.ParserCombinators.ReadP + +data Panic = Panic String deriving (Typeable, Show) +instance Exception Panic + +panic :: String -> a +panic msg = throw $ Panic msg + +handlePanic :: IO a -> IO a +handlePanic action = + action `catch` \(Panic msg) -> errMsg msg >> exitFailure + +errMsg :: String -> IO () +errMsg str = do + prog <- getProgName + hPutStrLn stderr $ prog ++ ": " ++ str + +align :: String -> String -> String -> String +align n an str = let + h:rest = lines str + [hm] = match n h + rest' = [ move (hm - rm) r | r <- rest, rm <- match an r] + in + unlines (h:rest') + where + match p str' = maybeToList $ + fst <$> find ((p `isPrefixOf`) . snd) ([0..] `zip` tails str') + move i str' | i > 0 = replicate i ' ' ++ str' + move i str' = drop i str' + + +-- | @getCabalConfigHeader "dist/setup-config"@ returns the cabal version and +-- compiler version +getCabalConfigHeader :: FilePath -> IO (Maybe (Version, Version)) +getCabalConfigHeader file = bracket (openFile file ReadMode) hClose $ \h -> do + parseHeader <$> BS.hGetLine h + +parseHeader :: ByteString -> Maybe (Version, Version) +parseHeader header = case BS8.words header of + ["Saved", "package", "config", "for", _pkgId , + "written", "by", cabalId, + "using", compId] + -> liftM2 (,) (ver cabalId) (ver compId) + _ -> Nothing + where + ver i = snd <$> parsePkgId i + +parsePkgId :: ByteString -> Maybe (ByteString, Version) +parsePkgId bs = + case BS8.split '-' bs of + [pkg, vers] -> Just (pkg, parseVer $ BS8.unpack vers) + _ -> Nothing + +parseVer :: String -> Version +parseVer vers = runReadP parseVersion vers + +-- majorVer :: Version -> Version +-- majorVer (Version b _) = Version (take 2 b) [] + +-- sameMajorVersion :: Version -> Version -> Bool +-- sameMajorVersion a b = majorVer a == majorVer b + +runReadP :: ReadP t -> String -> t +runReadP p i = let (a,""):[] = filter ((=="") . snd) $ readP_to_S p i in a diff --git a/cabal-helper/Main.hs b/CabalHelper/Main.hs similarity index 89% rename from cabal-helper/Main.hs rename to CabalHelper/Main.hs index a405d1e..b5ca210 100644 --- a/cabal-helper/Main.hs +++ b/CabalHelper/Main.hs @@ -33,6 +33,8 @@ import Distribution.PackageDescription (PackageDescription, import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.Simple.Program (requireProgram, ghcProgram) +import Distribution.Simple.Program.Types (ConfiguredProgram(..)) import Distribution.Simple.Configure (getPersistBuildConfig) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), Component(..), @@ -70,26 +72,9 @@ import System.Exit import System.IO import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO) import Text.Printf -import Common ---- \ / These types MUST be in sync with the copies in lib:ghc-mod -data GmComponentName = GmSetupHsName - | GmLibName - | GmExeName String - | GmTestName String - | GmBenchName String - deriving (Eq, Ord, Read, Show) -data GmCabalHelperResponse - = GmCabalHelperStrings [(GmComponentName, [String])] - | GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [ModuleName])] - | GmCabalHelperLbi String - deriving (Read, Show) ---- ^ These types MUST be in sync with the copies in ../Types.hs - - --- MUST be compatible to the one in GHC -newtype ModuleName = ModuleName String - deriving (Eq, Ord, Read, Show) +import CabalHelper.Common +import CabalHelper.Types usage = do prog <- getProgName @@ -177,7 +162,7 @@ main = do [] -> removeInplaceDeps pd clbi opts = componentGhcOptions v lbi bi clbi' outdir in - renderGhcOptions (compiler lbi) $ opts `mappend` adopts + renderGhcOptions' lbi v $ opts `mappend` adopts "ghc-src-options":flags -> Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ @@ -200,7 +185,7 @@ main = do ghcOptSourcePath = ghcOptSourcePath opts } in - renderGhcOptions comp $ opts `mappend` adopts + renderGhcOptions' lbi v $ opts `mappend` adopts "ghc-pkg-options":flags -> Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ @@ -218,19 +203,19 @@ main = do ghcOptHideAllPackages = ghcOptHideAllPackages opts } in - renderGhcOptions (compiler lbi) $ opts' `mappend` adopts + renderGhcOptions' lbi v $ opts' `mappend` adopts "entrypoints":[] -> do eps <- componentsMap lbi v distdir $ \c clbi bi -> - componentEntrypoints c + return $ componentEntrypoints c -- MUST append Setup component at the end otherwise CabalHelper gets -- confused - let eps' = eps ++ [(GmSetupHsName, Right [ModuleName "Setup"])] + let eps' = eps ++ [(GmSetupHsName, Right [GmModuleName "Setup"])] return $ Just $ GmCabalHelperEntrypoints eps' "source-dirs":[] -> Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ - \c clbi bi -> hsSourceDirs bi + \c clbi bi -> return $ hsSourceDirs bi "print-lbi":[] -> return $ Just $ GmCabalHelperLbi $ show lbi @@ -253,7 +238,7 @@ componentsMap :: LocalBuildInfo -> ( Component -> ComponentLocalBuildInfo -> BuildInfo - -> a) + -> IO a) -> IO [(GmComponentName, a)] componentsMap lbi v distdir f = do let pd = localPkgDescr lbi @@ -265,7 +250,8 @@ componentsMap lbi v distdir f = do name = componentNameFromComponent c l' <- readIORef lr - writeIORef lr $ (componentNameToGm name, f c clbi bi):l' + r <- f c clbi bi + writeIORef lr $ (componentNameToGm name, r):l' reverse <$> readIORef lr componentNameToGm CLibName = GmLibName @@ -287,10 +273,10 @@ componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteLibV09 _ _, ..}) componentOutDir lbi (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ _, ..})= exeOutDir lbi benchmarkName -gmModuleName :: C.ModuleName -> ModuleName -gmModuleName = ModuleName . intercalate "." . components +gmModuleName :: C.ModuleName -> GmModuleName +gmModuleName = GmModuleName . intercalate "." . components -componentEntrypoints :: Component -> Either FilePath [ModuleName] +componentEntrypoints :: Component -> Either FilePath [GmModuleName] componentEntrypoints (CLib Library {..}) = Right $ map gmModuleName exposedModules componentEntrypoints (CExe Executable {..}) @@ -343,3 +329,12 @@ removeInplaceDeps pd clbi = let where isInplaceDep :: (InstalledPackageId, PackageId) -> Bool isInplaceDep (ipid, pid) = inplacePackageId pid == ipid + +renderGhcOptions' lbi v opts = do +#if CABAL_MAJOR == 1 && CABAL_MINOR < 20 + (ghcProg, _) <- requireProgram v ghcProgram (withPrograms lbi) + let Just ghcVer = programVersion ghcProg + return $ renderGhcOptions ghcVer opts +#else + return $ renderGhcOptions (compiler lbi) opts +#endif diff --git a/CabalHelper/Types.hs b/CabalHelper/Types.hs new file mode 100644 index 0000000..273df7d --- /dev/null +++ b/CabalHelper/Types.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} +module CabalHelper.Types where + +newtype GmModuleName = GmModuleName String + deriving (Read, Show) + +data GmComponentName = GmSetupHsName + | GmLibName + | GmExeName String + | GmTestName String + | GmBenchName String + deriving (Eq, Ord, Read, Show) + +data GmCabalHelperResponse + = GmCabalHelperStrings [(GmComponentName, [String])] + | GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [GmModuleName])] + | GmCabalHelperLbi String + deriving (Read, Show) diff --git a/cabal-helper/Wrapper.hs b/CabalHelper/Wrapper.hs similarity index 55% rename from cabal-helper/Wrapper.hs rename to CabalHelper/Wrapper.hs index 40c6315..9c460ab 100644 --- a/cabal-helper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -14,7 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE TemplateHaskell, OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE TemplateHaskell, RecordWildCards #-} module Main where import Control.Applicative @@ -26,11 +26,7 @@ import Data.List import Data.Maybe import Data.String import Data.Version -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 import Text.Printf -import Text.ParserCombinators.ReadP import System.Environment import System.Directory import System.FilePath @@ -44,7 +40,7 @@ import Distribution.Text (display) import NotCPP.Declarations import Paths_ghc_mod -import Common +import CabalHelper.Common import Utils ifD [d| getExecutablePath = getProgName |] @@ -61,21 +57,21 @@ usage = do \)\n" main :: IO () -main = do +main = handlePanic $ do args <- getArgs case args of "print-appdatadir":[] -> putStrLn =<< appDataDir "print-build-platform":[] -> putStrLn $ display buildPlatform distdir:_ -> do cfgf <- canonicalizePath (distdir "setup-config") - mhdr <- (parseHeader =<<) . listToMaybe . BS8.lines <$> BS.readFile cfgf + mhdr <- getCabalConfigHeader cfgf case mhdr of - Nothing -> error $ printf "\ + Nothing -> panic $ printf "\ \Could not read Cabal's persistent setup configuration header\n\ \- Check first line of: %s\n\ \- Maybe try: $ cabal configure" cfgf - Just Header {..} -> do + Just (hdrCabalVersion, _hdrCompilerVersion) -> do eexe <- compileHelper hdrCabalVersion case eexe of Left e -> exitWith e @@ -92,17 +88,17 @@ tryFindSrcDirInGhcModTree :: IO (Maybe FilePath) tryFindSrcDirInGhcModTree = do dir <- (!!4) . iterate takeDirectory <$> getExecutablePath exists <- doesFileExist $ dir "ghc-mod.cabal" - src_exists <- doesFileExist $ dir "cabal-helper/Main.hs" + src_exists <- doesFileExist $ dir "CabalHelper/Main.hs" if exists && src_exists - then return $ Just (dir "cabal-helper") + then return $ Just dir else return Nothing tryFindRealSrcDir :: IO (Maybe FilePath) tryFindRealSrcDir = do datadir <- getDataDir - exists <- doesFileExist $ datadir "cabal-helper/Main.hs" + exists <- doesFileExist $ datadir "CabalHelper/Main.hs" return $ if exists - then Just $ datadir "cabal-helper" + then Just datadir else Nothing findCabalHelperSourceDir :: IO FilePath @@ -116,35 +112,52 @@ findCabalHelperSourceDir = do compileHelper :: Version -> IO (Either ExitCode FilePath) compileHelper cabalVer = do chdir <- findCabalHelperSourceDir - mver <- find (sameMajorVersion cabalVer) <$> listCabalVersions - couldBeSrcDir <- takeDirectory <$> getDataDir - case mver of - Nothing -> do - let cabalFile = couldBeSrcDir "Cabal.cabal" - cabal <- doesFileExist cabalFile - if cabal - then do - ver <- cabalFileVersion <$> readFile cabalFile - compile $ Compile chdir (Just couldBeSrcDir) ver [] - else errorNoCabal cabalVer - Just ver -> - compile $ Compile chdir Nothing ver [cabalPkgId ver] + -- First check if we already compiled this version of cabal + db_exists <- cabalPkgDbExists cabalVer + case db_exists of + True -> compileWithPkg chdir . Just =<< cabalPkgDb cabalVer + False -> do + -- Next check if this version is globally available + mver <- find (== cabalVer) <$> listCabalVersions + couldBeSrcDir <- takeDirectory <$> getDataDir + case mver of + Nothing -> do + -- If not see if we're in a cabal source tree + let cabalFile = couldBeSrcDir "Cabal.cabal" + cabal <- doesFileExist cabalFile + if cabal + then do + ver <- cabalFileVersion <$> readFile cabalFile + compileWithCabalTree chdir ver couldBeSrcDir + else do + -- otherwise compile the requested cabal version into an isolated + -- package-db + db <- installCabal cabalVer + compileWithPkg chdir (Just db) + Just _ -> + compileWithPkg chdir Nothing + where + compileWithCabalTree chdir ver srcDir = + compile $ Compile chdir (Just srcDir) Nothing ver [] + + compileWithPkg chdir mdb = + compile $ Compile chdir Nothing mdb cabalVer [cabalPkgId cabalVer] + cabalPkgId v = "Cabal-" ++ showVersion v -errorNoCabal :: Version -> a -errorNoCabal cabalVer = error $ printf "\ -\No appropriate Cabal package found, wanted version %s.\n\ -\- Check output of: $ ghc-pkg list Cabal\n\ -\- Maybe try: $ cabal install Cabal --constraint 'Cabal == %s.*'" sver mjver - where - sver = showVersion cabalVer - mjver = showVersion $ majorVer cabalVer +-- errorNoCabal :: Version -> a +-- errorNoCabal cabalVer = panic $ printf "\ +-- \No appropriate Cabal package found, wanted version %s.\n\ +-- \- Check output of: $ ghc-pkg list Cabal\n\ +-- \- Maybe try: $ cabal install Cabal --constraint 'Cabal == %s'" sver sver +-- where +-- sver = showVersion cabalVer errorNoMain :: FilePath -> a -errorNoMain datadir = error $ printf "\ -\Could not find $datadir/cabal-helper/Main.hs!\n\ +errorNoMain datadir = panic $ printf "\ +\Could not find $datadir/CabalHelper/Main.hs!\n\ \\n\ \If you are a developer you can use the environment variable `ghc_mod_datadir'\n\ \to override $datadir[1], `$ export ghc_mod_datadir=$PWD' will work in the\n\ @@ -158,6 +171,7 @@ errorNoMain datadir = error $ printf "\ data Compile = Compile { cabalHelperSourceDir :: FilePath, cabalSourceDir :: Maybe FilePath, + packageDb :: Maybe FilePath, cabalVersion :: Version, packageDeps :: [String] } @@ -167,7 +181,7 @@ compile Compile {..} = do outdir <- appDataDir createDirectoryIfMissing True outdir - let exe = outdir "cabal-helper-" ++ showVersion (majorVer cabalVersion) + let exe = outdir "cabal-helper-" ++ showVersion cabalVersion recompile <- case cabalSourceDir of @@ -182,24 +196,43 @@ compile Compile {..} = do concat [ [ "-outputdir", outdir , "-o", exe + , "-optP-DCABAL_HELPER=1" , "-optP-DCABAL_MAJOR=" ++ show mj , "-optP-DCABAL_MINOR=" ++ show mi ], + maybeToList $ ("-package-db="++) <$> packageDb, map ("-i"++) $ cabalHelperSourceDir:maybeToList cabalSourceDir, concatMap (\p -> ["-package", p]) packageDeps, - [ "--make", cabalHelperSourceDir "Main.hs" ] + [ "--make", cabalHelperSourceDir "CabalHelper/Main.hs" ] ] if recompile then do - (_, _, _, h) <- createProcess - (proc "ghc" ghc_opts) { std_out = UseHandle stderr } - rv <- waitForProcess h + rv <- callProcessStderr' Nothing "ghc" ghc_opts return $ case rv of ExitSuccess -> Right exe e@(ExitFailure _) -> Left e else return $ Right exe +callProcessStderr' :: Maybe FilePath -> FilePath -> [String] -> IO ExitCode +callProcessStderr' mwd exe args = do + (_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr + , cwd = mwd } + waitForProcess h + +callProcessStderr :: Maybe FilePath -> FilePath -> [String] -> IO () +callProcessStderr mwd exe args = do + rv <- callProcessStderr' mwd exe args + case rv of + ExitSuccess -> return () + ExitFailure v -> processFailedException "callProcessStderr" exe args v + +processFailedException :: String -> String -> [String] -> Int -> IO a +processFailedException fn exe args rv = + panic $ concat [fn, ": ", exe, " " + , intercalate " " (map show args) + , " (exit " ++ show rv ++ ")"] + timeHsFiles :: FilePath -> IO [TimedFile] timeHsFiles dir = do fs <- map (dir) <$> getDirectoryContents dir @@ -209,17 +242,50 @@ timeHsFiles dir = do exists <- doesFileExist f return $ exists && ".hs" `isSuffixOf` f +installCabal :: Version -> IO FilePath +installCabal ver = do + db <- createPkgDb ver + callProcessStderr (Just "/") "cabal" [ "--package-db=clear" + , "--package-db=global" + , "--package-db=" ++ db + , "-j1" + , "install", "Cabal-"++showVersion ver + ] + return db +createPkgDb :: Version -> IO FilePath +createPkgDb ver = do + db <- cabalPkgDb ver + exists <- doesDirectoryExist db + when (not exists) $ callProcessStderr Nothing "ghc-pkg" ["init", db] + return db + +cabalPkgDb :: Version -> IO FilePath +cabalPkgDb ver = do + appdir <- appDataDir + return $ appdir "cabal-" ++ showVersion ver ++ "-db" + +cabalPkgDbExists :: Version -> IO Bool +cabalPkgDbExists ver = do + db <- cabalPkgDb ver + dexists <- doesDirectoryExist db + case dexists of + False -> return False + True -> do + vers <- listCabalVersions' (Just db) + return $ ver `elem` vers + +listCabalVersions :: IO [Version] +listCabalVersions = listCabalVersions' Nothing -- TODO: Include sandbox? Probably only relevant for build-type:custom projects. -listCabalVersions :: IO [Version] -listCabalVersions = do - catMaybes . map (fmap snd . parsePkgId . fromString) . words - <$> readProcess "ghc-pkg" ["list", "--simple-output", "Cabal"] "" +listCabalVersions' :: Maybe FilePath -> IO [Version] +listCabalVersions' mdb = do + let mdbopt = ("--package-db="++) <$> mdb + opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt -data Header = Header { hdrCabalVersion :: Version - , hdrCompilerVersion :: Version - } + catMaybes . map (fmap snd . parsePkgId . fromString) . words + <$> readProcess "ghc-pkg" opts "" -- | Find @version: XXX@ delcaration in a cabal file cabalFileVersion :: String -> Version @@ -228,31 +294,3 @@ cabalFileVersion cabalFile = do where ls = map (map toLower) $ lines cabalFile extract = dropWhile (/=':') >>> dropWhile isSpace >>> takeWhile (not . isSpace) - -parseHeader :: ByteString -> Maybe Header -parseHeader header = case BS8.words header of - ["Saved", "package", "config", "for", _pkgId , - "written", "by", cabalId, - "using", compId] - -> liftM2 Header (ver cabalId) (ver compId) - _ -> error "parsing setup-config header failed" - where - ver i = snd <$> parsePkgId i - -parsePkgId :: ByteString -> Maybe (ByteString, Version) -parsePkgId bs = - case BS8.split '-' bs of - [pkg, vers] -> Just (pkg, parseVer $ BS8.unpack vers) - _ -> Nothing - -parseVer :: String -> Version -parseVer vers = runReadP parseVersion vers - -majorVer :: Version -> Version -majorVer (Version b _) = Version (take 2 b) [] - -sameMajorVersion :: Version -> Version -> Bool -sameMajorVersion a b = majorVer a == majorVer b - -runReadP :: ReadP t -> String -> t -runReadP p i = let (a,""):[] = filter ((=="") . snd) $ readP_to_S p i in a diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 1542f94..c98bd63 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -23,6 +23,7 @@ module Language.Haskell.GhcMod.CabalHelper ( ) where import Control.Applicative +import Control.Arrow import Control.Monad import Data.Monoid import Data.List @@ -100,5 +101,9 @@ cabalHelper = withCabal $ do Just (GmCabalHelperStrings ghcOpts), Just (GmCabalHelperStrings ghcSrcOpts), Just (GmCabalHelperStrings ghcPkgOpts) ] = res + eps' = map (second $ fmap $ map md) eps - return $ CabalHelper eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts + return $ CabalHelper eps' srcDirs ghcOpts ghcSrcOpts ghcPkgOpts + + where + md (GmModuleName mn) = mkModuleName mn diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 818a955..8eb91c2 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -24,7 +24,6 @@ import Data.List import Data.Char import Data.Maybe import Data.Traversable (traverse) -import Types import System.Directory import System.FilePath import System.IO.Unsafe diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index db71b60..ceed2d7 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.Types ( module Language.Haskell.GhcMod.Types - , module Types + , module CabalHelper.Types , ModuleName , mkModuleName , moduleNameString @@ -11,6 +11,7 @@ module Language.Haskell.GhcMod.Types ( import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Error (Error(..)) import Control.Exception (Exception) +import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -22,7 +23,7 @@ import MonadUtils (MonadIO) import GHC (ModuleName, moduleNameString, mkModuleName) import PackageConfig (PackageConfig) -import Types +import CabalHelper.Types -- | A constraint alias (-XConstraintKinds) to make functions dealing with -- 'GhcModT' somewhat cleaner. @@ -95,6 +96,52 @@ data Cradle = Cradle { ---------------------------------------------------------------- +-- | GHC package database flags. +data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show) + +-- | A single GHC command line option. +type GHCOption = String + +-- | An include directory for modules. +type IncludeDir = FilePath + +-- | A package name. +type PackageBaseName = String + +-- | A package version. +type PackageVersion = String + +-- | A package id. +type PackageId = String + +-- | A package's name, verson and id. +type Package = (PackageBaseName, PackageVersion, PackageId) + +pkgName :: Package -> PackageBaseName +pkgName (n,_,_) = n + +pkgVer :: Package -> PackageVersion +pkgVer (_,v,_) = v + +pkgId :: Package -> PackageId +pkgId (_,_,i) = i + +showPkg :: Package -> String +showPkg (n,v,_) = intercalate "-" [n,v] + +showPkgId :: Package -> String +showPkgId (n,v,i) = intercalate "-" [n,v,i] + +-- | Haskell expression. +type Expression = String + +-- | Module name. +type ModuleString = String + +-- | A Module +type Module = [String] + + data GmLogLevel = GmPanic | GmException | GmError @@ -140,21 +187,6 @@ instance Read ModuleName where (m,t) <- readsPrec (app_prec+1) s]) r where app_prec = 10 - ---- \ / These types MUST be in sync with the copies in cabal-helper/Main.hs -data GmComponentName = GmSetupHsName - | GmLibName - | GmExeName String - | GmTestName String - | GmBenchName String - deriving (Eq, Ord, Read, Show) -data GmCabalHelperResponse - = GmCabalHelperStrings [(GmComponentName, [String])] - | GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [ModuleName])] - | GmCabalHelperLbi String - deriving (Read, Show) ---- ^ These types MUST be in sync with the copies in cabal-helper/Main.hs - data GhcModError = GMENoMsg -- ^ Unknown error diff --git a/cabal-helper/Common.hs b/cabal-helper/Common.hs deleted file mode 100644 index ed58f81..0000000 --- a/cabal-helper/Common.hs +++ /dev/null @@ -1,41 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -module Common where - -import Control.Applicative -import Data.List -import Data.Maybe -import System.Environment -import System.IO - -errMsg :: String -> IO () -errMsg str = do - prog <- getProgName - hPutStrLn stderr $ prog ++ ": " ++ str - -align :: String -> String -> String -> String -align n an str = let - h:rest = lines str - [hm] = match n h - rest' = [ move (hm - rm) r | r <- rest, rm <- match an r] - in - unlines (h:rest') - where - match p str' = maybeToList $ - fst <$> find ((p `isPrefixOf`) . snd) ([0..] `zip` tails str') - move i str' | i > 0 = replicate i ' ' ++ str' - move i str' = drop i str' diff --git a/ghc-mod.cabal b/ghc-mod.cabal index b6dfa20..be85601 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -23,7 +23,7 @@ Cabal-Version: >= 1.16 Build-Type: Custom Data-Files: elisp/Makefile elisp/*.el - cabal-helper/*.hs + CabalHelper/*.hs Extra-Source-Files: ChangeLog SetupCompat.hs @@ -65,8 +65,8 @@ Library Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Internal Other-Modules: Paths_ghc_mod - Types Utils + CabalHelper.Types Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Browse Language.Haskell.GhcMod.CaseSplit @@ -177,10 +177,10 @@ Executable ghc-modi Executable cabal-helper-wrapper Default-Language: Haskell2010 Other-Extensions: TemplateHaskell - Main-Is: Wrapper.hs + Main-Is: CabalHelper/Wrapper.hs Other-Modules: Paths_ghc_mod GHC-Options: -Wall - HS-Source-Dirs: cabal-helper, . + HS-Source-Dirs: . X-Install-Target: $libexecdir Build-Depends: base >= 4.0 && < 5 , bytestring @@ -207,14 +207,13 @@ Test-Suite doctest Test-Suite spec Default-Language: Haskell2010 Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, - ConstraintKinds, FlexibleContexts, OverloadedStrings + ConstraintKinds, FlexibleContexts Main-Is: Main.hs Hs-Source-Dirs: test, . Ghc-Options: -Wall -fno-warn-deprecations CPP-Options: -DSPEC=1 Type: exitcode-stdio-1.0 Other-Modules: Paths_ghc_mod - Types Dir Spec TestUtils From f0ea445a9bbe9b93d06505601cf87ae648b76755 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 4 Mar 2015 21:48:21 +0100 Subject: [PATCH 021/207] Cleanup errors and logging a bit --- .travis.yml | 4 + Language/Haskell/GhcMod/Error.hs | 18 ++-- Language/Haskell/GhcMod/Logging.hs | 2 +- Language/Haskell/GhcMod/PathsAndFiles.hs | 1 + Language/Haskell/GhcMod/Pretty.hs | 4 +- Language/Haskell/GhcMod/Types.hs | 2 +- Language/Haskell/GhcMod/Utils.hs | 1 + SetupCompat.hs | 35 ++++--- ghc-mod.cabal | 39 +++++--- test/BrowseSpec.hs | 9 +- test/CabalApiSpec.hs | 88 ----------------- test/CheckSpec.hs | 17 ++-- test/CradleSpec.hs | 93 ++++++++++-------- test/Dir.hs | 10 +- test/InfoSpec.hs | 46 ++++----- test/LintSpec.hs | 6 +- test/Main.hs | 22 ++++- test/MonadSpec.hs | 24 +---- test/PathsAndFilesSpec.hs | 24 ++--- test/TestUtils.hs | 72 +++++++++----- test/UtilsSpec.hs | 10 -- ....1.3-2b161c6bf77657aa17e1681d83cb051b.conf | 4 - .../.cabal-sandbox/packages/00-index.cache | 0 .../data/.cabal-sandbox/packages/00-index.tar | Bin 10240 -> 0 bytes test/data/Bar.hs | 5 - test/data/Baz.hs | 5 - test/data/Foo.hs | 9 -- test/data/ForeignExport.hs | 10 -- test/data/Info.hs | 8 -- test/data/Main.hs | 3 - test/data/Mutual1.hs | 5 - test/data/Mutual2.hs | 3 - test/data/Unicode.hs | 4 - test/data/bad.config | 1 - test/data/cabal.sandbox.config.in | 25 ----- test/data/cabalapi.cabal | 67 ------------- test/data/ghc-mod-check/Data/Foo.hs | 11 --- test/data/ghc-mod-check/ghc-mod-check.cabal | 3 +- test/data/hlint.hs | 5 - test/data/subdir1/subdir2/dummy | 1 - test/doctests.hs | 2 +- 41 files changed, 242 insertions(+), 456 deletions(-) delete mode 100644 test/CabalApiSpec.hs delete mode 100644 test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf delete mode 100644 test/data/.cabal-sandbox/packages/00-index.cache delete mode 100644 test/data/.cabal-sandbox/packages/00-index.tar delete mode 100644 test/data/Bar.hs delete mode 100644 test/data/Baz.hs delete mode 100644 test/data/Foo.hs delete mode 100644 test/data/ForeignExport.hs delete mode 100644 test/data/Info.hs delete mode 100644 test/data/Main.hs delete mode 100644 test/data/Mutual1.hs delete mode 100644 test/data/Mutual2.hs delete mode 100644 test/data/Unicode.hs delete mode 100644 test/data/bad.config delete mode 100644 test/data/cabal.sandbox.config.in delete mode 100644 test/data/cabalapi.cabal delete mode 100644 test/data/ghc-mod-check/Data/Foo.hs delete mode 100644 test/data/hlint.hs delete mode 100644 test/data/subdir1/subdir2/dummy diff --git a/.travis.yml b/.travis.yml index f21baf1..bb80427 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,7 +6,11 @@ ghc: install: - cabal update +# - ( $CABAL122 && cabal install cabal-install --constraint "Cabal >= 1.22" && ghc-pkg unregister Cabal ) || true + - echo $PATH + - which cabal - cabal install happy --constraint 'transformers <= 0.3.0.0' + - cabal install Cabal --constraint "Cabal == $(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | awk -vFS=. '{ print $1 "." $2 }' | tail -n1).*" - happy --version - cabal install -j --only-dependencies --enable-tests diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 73dd672..4675b13 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -35,7 +35,7 @@ module Language.Haskell.GhcMod.Error ( import Control.Arrow import Control.Exception -import Control.Monad.Error +import Control.Monad.Error hiding (MonadIO, liftIO) import qualified Data.Set as Set import Data.List import Data.Version @@ -49,9 +49,9 @@ import Config (cProjectVersion, cHostPlatformString) import Paths_ghc_mod (version) import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Pretty - type GmError m = MonadError GhcModError m gmCsfeDoc :: GMConfigStateFileError -> Doc @@ -101,10 +101,15 @@ gmeDoc e = case e of GMECabalCompAssignment ctx -> text "Could not find a consistent component assignment for modules:" $$ (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$ - empty $$ - text "Try this and that" + text "" $$ + text "- Are you sure all these modules exist?" $$ + text "- Maybe try enabling test suites and or benchmarks:" $$ + nest 4 (backticks $ text "cabal configure --enable-tests --enable-benchmarks") $$ + text "- To find out which components ghc-mod knows about try:" $$ + nest 4 (backticks $ text "ghc-mod debug") where + backticks d = char '`' <> d <> char '`' ctxDoc = moduleDoc *** compsDoc >>> first (<> colon) >>> uncurry (flip hang 4) @@ -177,10 +182,11 @@ tryFix action f = do data GHandler m a = forall e . Exception e => GHandler (e -> m a) -gcatches :: ExceptionMonad m => m a -> [GHandler m a] -> m a +gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a gcatches io handlers = io `gcatch` gcatchesHandler handlers -gcatchesHandler :: ExceptionMonad m => [GHandler m a] -> SomeException -> m a +gcatchesHandler :: (MonadIO m, ExceptionMonad m) + => [GHandler m a] -> SomeException -> m a gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers where tryHandler (GHandler handler) res = case fromException e of diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 63c465f..9c7ebe9 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -54,5 +54,5 @@ gmLog level loc' doc = do msg = gmRenderDoc $ gmLogLevelDoc level <+> loc <+> doc when (Just level <= level') $ - liftIO $ hPutStrLn stderr msg + liftIO $ hPutStr stderr msg gmlJournal (GhcModLog Nothing [(level, render loc, msg)]) diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 8eb91c2..d0b925d 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -29,6 +29,7 @@ import System.FilePath import System.IO.Unsafe import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Read import Language.Haskell.GhcMod.Utils hiding (dropWhileEnd) diff --git a/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs index 7a023bd..a6a8e0e 100644 --- a/Language/Haskell/GhcMod/Pretty.hs +++ b/Language/Haskell/GhcMod/Pretty.hs @@ -17,6 +17,8 @@ module Language.Haskell.GhcMod.Pretty where import Control.Arrow hiding ((<+>)) +import Data.Char +import Data.List import Text.PrettyPrint import Language.Haskell.GhcMod.Types @@ -56,7 +58,7 @@ warnDoc :: Doc -> Doc warnDoc d = text "Warning" <+>: d strDoc :: String -> Doc -strDoc str = doc str +strDoc str = doc (dropWhileEnd isSpace str) where doc :: String -> Doc doc = lines diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index ceed2d7..1f11c96 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -68,7 +68,7 @@ defaultOptions :: Options defaultOptions = Options { outputStyle = PlainStyle , lineSeparator = LineSeparator "\0" - , logLevel = GmPanic + , logLevel = GmException -- , ghcProgram = "ghc" , cabalProgram = "cabal" , ghcUserOptions= [] diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 7aafc69..938b037 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -25,6 +25,7 @@ import Control.Arrow import Control.Applicative import Data.Char import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.Monad.Types import Exception import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist) import System.Process (readProcess) diff --git a/SetupCompat.hs b/SetupCompat.hs index 028dacd..13707fc 100644 --- a/SetupCompat.hs +++ b/SetupCompat.hs @@ -15,12 +15,23 @@ import Distribution.Simple.Setup import Distribution.Simple.Install import qualified Data.Map as M +import Data.Map (Map) import NotCPP.Declarations import Language.Haskell.TH -$(ifndefD "componentsConfigs" [d| deriving instance (Ord ComponentName) |] ) +-- $(ifdefD "componentsConfigs" [d| deriving instance (Ord ComponentName) |] ) + +$(ifD [d| + + showComponentName :: ComponentName -> String + showComponentName CLibName = "library" + showComponentName (CExeName name) = "executable '" ++ name ++ "'" + showComponentName (CTestName name) = "test suite '" ++ name ++ "'" + showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'" + + |]) $(ifelsedefD "componentsConfigs" [d| @@ -38,8 +49,7 @@ $(ifelsedefD "componentsConfigs" [d| -> LocalBuildInfo setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs where --- gcs :: [ [(ComponentLocalBuildInfo, ComponentName, a)] ] - gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` fst3) cs + gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` showComponentName . fst3) cs fst3 (x,_,_) = x @@ -130,16 +140,17 @@ $(ifD [d| $(ifelsedefD "componentPackageRenaming" [d| + -- M.Map PackageName + newtype Deps = Deps { unDeps :: ([(InstalledPackageId, PackageId)], Map PackageName $(cT "ModuleRenaming")) } +-- $(return $ TySynD $(mkName "Deps") [] [t| |] ) - type Deps = ([(InstalledPackageId, PackageId)], M.Map PackageName $(cT "ModuleRenaming")) - - noDeps = ([], M.empty) + noDeps = Deps ([], M.empty) getDeps :: ComponentLocalBuildInfo -> Deps - getDeps = componentPackageDeps &&& $(nE "componentPackageRenaming") + getDeps = componentPackageDeps &&& $(nE "componentPackageRenaming") >>> Deps setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo - setUnionDeps (deps, rns) clbi = let + setUnionDeps (Deps (deps, rns)) clbi = let clbi' = setComponentPackageRenaming clbi rns cpdeps = componentPackageDeps clbi in @@ -166,15 +177,15 @@ $(ifelsedefD "componentPackageRenaming" [d| |] [d| - type Deps = [(InstalledPackageId, PackageId)] + newtype Deps = Deps { unDeps :: [(InstalledPackageId, PackageId)] } - noDeps = [] + noDeps = Deps [] getDeps :: ComponentLocalBuildInfo -> Deps - getDeps lbi = componentPackageDeps lbi + getDeps lbi = Deps $ componentPackageDeps lbi setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo - setUnionDeps deps clbi = let + setUnionDeps (Deps deps) clbi = let cpdeps = componentPackageDeps clbi in clbi { diff --git a/ghc-mod.cabal b/ghc-mod.cabal index be85601..3c81496 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -5,6 +5,7 @@ Author: Kazu Yamamoto Alejandro Serrano Maintainer: Kazu Yamamoto License: AGPL-3 +License-File: LICENSE License-Files: COPYING.BSD3 COPYING.AGPL3 Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ Synopsis: Happy Haskell Programming @@ -28,34 +29,42 @@ Data-Files: elisp/Makefile Extra-Source-Files: ChangeLog SetupCompat.hs NotCPP/*.hs - test/data/*.cabal - test/data/*.hs - test/data/cabal.sandbox.config.in - test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf + test/data/annotations/*.hs test/data/broken-cabal/*.cabal test/data/broken-cabal/cabal.sandbox.config.in - test/data/broken-sandbox/*.cabal test/data/broken-sandbox/cabal.sandbox.config + test/data/broken-sandbox/dummy.cabal + test/data/cabal-flags/cabal-flags.cabal + test/data/cabal-project/*.cabal + test/data/cabal-project/*.hs + test/data/cabal-project/cabal.sandbox.config.in + test/data/cabal-project/subdir1/subdir2/dummy test/data/case-split/*.hs - test/data/cabal-flags/*.cabal - test/data/check-test-subdir/*.cabal - test/data/check-test-subdir/src/Check/Test/*.hs - test/data/check-test-subdir/test/*.hs - test/data/check-test-subdir/test/Bar/*.hs test/data/check-packageid/cabal.sandbox.config.in test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf + test/data/check-test-subdir/*.cabal + test/data/check-test-subdir/src/Check/Test/*.hs test/data/duplicate-pkgver/cabal.sandbox.config.in test/data/duplicate-pkgver/duplicate-pkgver.cabal test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-1.0-7c59d13f32294d1ef6dc6233c24df961.conf test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-14e543bdae2da4d2aeff5386892c9112.conf test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf - test/data/pattern-synonyms/*.cabal - test/data/pattern-synonyms/*.hs + test/data/foreign-export/*.hs test/data/ghc-mod-check/*.cabal test/data/ghc-mod-check/*.hs - test/data/ghc-mod-check/Data/*.hs - test/data/subdir1/subdir2/dummy - test/data/.cabal-sandbox/packages/00-index.tar + test/data/ghc-mod-check/lib/Data/*.hs + test/data/hlint/*.hs + test/data/home-module-graph/cpp/*.hs + test/data/home-module-graph/cycle/*.hs + test/data/home-module-graph/errors/*.hs + test/data/home-module-graph/indirect/*.hs + test/data/home-module-graph/indirect-update/*.hs + test/data/import-cycle/*.hs + test/data/non-exported/*.hs + test/data/pattern-synonyms/*.cabal + test/data/pattern-synonyms/*.hs + test/data/quasi-quotes/*.hs + test/data/template-haskell/*.hs Library Default-Language: Haskell2010 diff --git a/test/BrowseSpec.hs b/test/BrowseSpec.hs index aa4942a..d615d50 100644 --- a/test/BrowseSpec.hs +++ b/test/BrowseSpec.hs @@ -26,7 +26,8 @@ spec = do syms `shouldContain` ["Left :: a -> Either a b"] describe "`browse' in a project directory" $ do - it "lists symbols defined in a a local module (e.g. `Baz.baz)" $ do - withDirectory_ "test/data" $ do - syms <- runD $ lines <$> browse "Baz" - syms `shouldContain` ["baz"] + it "can list symbols defined in a a local module" $ do + withDirectory_ "test/data/ghc-mod-check/lib" $ do + syms <- runD $ lines <$> browse "Data.Foo" + syms `shouldContain` ["foo"] + syms `shouldContain` ["fibonacci"] diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs deleted file mode 100644 index 591c78b..0000000 --- a/test/CabalApiSpec.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module CabalApiSpec where - -import Control.Applicative -import Language.Haskell.GhcMod.CabalApi -import Language.Haskell.GhcMod.Cradle -import Language.Haskell.GhcMod.Types -import Test.Hspec -import System.Directory -import System.FilePath - -import Dir -import TestUtils - -import Config (cProjectVersionInt) -- ghc version - -ghcVersion :: Int -ghcVersion = read cProjectVersionInt - -spec :: Spec -spec = do - describe "parseCabalFile" $ do - it "throws an exception if the cabal file is broken" $ do - shouldReturnError $ do - withDirectory_ "test/data/broken-cabal" $ do - crdl <- findCradle - runD' $ parseCabalFile crdl "broken.cabal" - - - describe "getCompilerOptions" $ do - it "gets necessary CompilerOptions" $ do - cwd <- getCurrentDirectory - withDirectory "test/data/subdir1/subdir2" $ \dir -> do - crdl <- findCradle - let Just cabalFile = cradleCabalFile crdl - pkgDesc <- runD $ parseCabalFile crdl cabalFile - res <- runD $ getCompilerOptions [] crdl pkgDesc - let res' = res { - ghcOptions = ghcOptions res - , includeDirs = map (toRelativeDir dir) (includeDirs res) - } - - let [fGlobalPkg, fNoUserPkg, fPkg, sb, _] = ghcOptions res' - - sb `shouldSatisfy` - isPkgConfDAt (cwd "test/data/.cabal-sandbox") - - if ghcVersion < 706 - then do - fGlobalPkg `shouldBe` "-global-package-conf" - fNoUserPkg `shouldBe` "-no-user-package-conf" - fPkg `shouldBe` "-package-conf" - - else do - fGlobalPkg `shouldBe` "-global-package-db" - fNoUserPkg `shouldBe` "-no-user-package-db" - fPkg `shouldBe` "-package-db" - - includeDirs res' `shouldBe` [ - "test/data", - "test/data/dist/build", - "test/data/dist/build/autogen", - "test/data/subdir1/subdir2", - "test/data/test"] - - (pkgName `map` depPackages res') `shouldContain` ["Cabal"] - - describe "cabalSourceDirs" $ do - it "extracts all hs-source-dirs" $ do - crdl <- findCradle' "test/data/check-test-subdir" - let cabalFile = "test/data/check-test-subdir/check-test-subdir.cabal" - dirs <- cabalSourceDirs . cabalAllBuildInfo - <$> runD (parseCabalFile crdl cabalFile) - - dirs `shouldBe` ["src", "test"] - - it "extracts all hs-source-dirs including \".\"" $ do - crdl <- findCradle' "test/data/" - dirs <- cabalSourceDirs . cabalAllBuildInfo - <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal") - dirs `shouldBe` [".", "test"] - - describe "cabalAllBuildInfo" $ do - it "extracts build info" $ do - crdl <- findCradle' "test/data/" - info <- cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal") - show info `shouldBe` "[BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\".\"], otherModules = [ModuleName [\"Browse\"],ModuleName [\"CabalApi\"],ModuleName [\"Cabal\"],ModuleName [\"CabalDev\"],ModuleName [\"Check\"],ModuleName [\"ErrMsg\"],ModuleName [\"Flag\"],ModuleName [\"GHCApi\"],ModuleName [\"GHCChoice\"],ModuleName [\"Gap\"],ModuleName [\"Info\"],ModuleName [\"Lang\"],ModuleName [\"Lint\"],ModuleName [\"List\"],ModuleName [\"Paths_ghc_mod\"],ModuleName [\"Types\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [(GHC,[\"-Wall\"])], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))),Dependency (PackageName \"template-haskell\") AnyVersion]},BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\"test\",\".\"], otherModules = [ModuleName [\"Expectation\"],ModuleName [\"BrowseSpec\"],ModuleName [\"CabalApiSpec\"],ModuleName [\"FlagSpec\"],ModuleName [\"LangSpec\"],ModuleName [\"LintSpec\"],ModuleName [\"ListSpec\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []})))]}]" diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index cccaaeb..75fb9f0 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-} module CheckSpec where -import Data.List (isSuffixOf, isInfixOf, isPrefixOf) +import Data.List (isInfixOf, isPrefixOf) --isSuffixOf, import Language.Haskell.GhcMod -import System.FilePath +--import System.FilePath import Test.Hspec import TestUtils @@ -17,20 +17,21 @@ spec = do res <- runD $ checkSyntax ["main.hs"] res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n" + it "works even if a module imports another module from a different directory" $ do withDirectory_ "test/data/check-test-subdir" $ do res <- runD $ checkSyntax ["test/Bar/Baz.hs"] res `shouldSatisfy` (("test" "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`) it "detects cyclic imports" $ do - withDirectory_ "test/data" $ do + withDirectory_ "test/data/import-cycle" $ do res <- runD $ checkSyntax ["Mutual1.hs"] res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`) it "works with modules using QuasiQuotes" $ do - withDirectory_ "test/data" $ do - res <- runD $ checkSyntax ["Baz.hs"] - res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`) + withDirectory_ "test/data/quasi-quotes" $ do + res <- runD $ checkSyntax ["QuasiQuotes.hs"] + res `shouldSatisfy` ("QuasiQuotes.hs:6:1:Warning:" `isInfixOf`) #if __GLASGOW_HASKELL__ >= 708 it "works with modules using PatternSynonyms" $ do @@ -40,12 +41,12 @@ spec = do #endif it "works with foreign exports" $ do - withDirectory_ "test/data" $ do + withDirectory_ "test/data/foreign-export" $ do res <- runD $ checkSyntax ["ForeignExport.hs"] res `shouldBe` "" context "when no errors are found" $ do it "doesn't output an empty line" $ do - withDirectory_ "test/data/ghc-mod-check/Data" $ do + withDirectory_ "test/data/ghc-mod-check/lib/Data" $ do res <- runD $ checkSyntax ["Foo.hs"] res `shouldBe` "" diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index f0fe38a..f39f277 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -4,54 +4,18 @@ import Control.Applicative import Data.List (isSuffixOf) import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Types -import System.Directory (canonicalizePath,getCurrentDirectory) -import System.FilePath ((), pathSeparator) +import System.Directory (canonicalizePath) +import System.FilePath (pathSeparator) import Test.Hspec import Dir import TestUtils -spec :: Spec -spec = do - describe "findCradle" $ do - it "returns the current directory" $ do - withDirectory_ "/" $ do - curDir <- stripLastDot <$> canonicalizePath "/" - res <- findCradle - cradleCurrentDir res `shouldBe` curDir - cradleRootDir res `shouldBe` curDir - cradleCabalFile res `shouldBe` Nothing - cradlePkgDbStack res `shouldBe` [GlobalDb,UserDb] - - it "finds a cabal file and a sandbox" $ do - cwd <- getCurrentDirectory - withDirectory "test/data/subdir1/subdir2" $ \dir -> do - res <- relativeCradle dir <$> findCradle - - cradleCurrentDir res `shouldBe` - "test" "data" "subdir1" "subdir2" - - cradleRootDir res `shouldBe` "test" "data" - - cradleCabalFile res `shouldBe` - Just ("test" "data" "cabalapi.cabal") - - let [GlobalDb, sb] = cradlePkgDbStack res - sb `shouldSatisfy` isPkgDbAt (cwd "test/data/.cabal-sandbox") - - it "works even if a sandbox config file is broken" $ do - withDirectory "test/data/broken-sandbox" $ \dir -> do - res <- relativeCradle dir <$> findCradle - cradleCurrentDir res `shouldBe` - "test" "data" "broken-sandbox" - - cradleRootDir res `shouldBe` - "test" "data" "broken-sandbox" - - cradleCabalFile res `shouldBe` - Just ("test" "data" "broken-sandbox" "dummy.cabal") - - cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb] +clean_ :: IO Cradle -> IO Cradle +clean_ f = do + crdl <- f + cleanupCradle crdl + return crdl relativeCradle :: FilePath -> Cradle -> Cradle relativeCradle dir crdl = crdl { @@ -65,3 +29,46 @@ stripLastDot :: FilePath -> FilePath stripLastDot path | (pathSeparator:'.':"") `isSuffixOf` path = init path | otherwise = path + +spec :: Spec +spec = do + describe "findCradle" $ do + it "returns the current directory" $ do + withDirectory_ "/" $ do + curDir <- stripLastDot <$> canonicalizePath "/" + res <- clean_ findCradle + cradleCurrentDir res `shouldBe` curDir + cradleRootDir res `shouldBe` curDir + cradleCabalFile res `shouldBe` Nothing + cradlePkgDbStack res `shouldBe` [GlobalDb,UserDb] + + it "finds a cabal file and a sandbox" $ do + cwd <- getCurrentDirectory + withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do + res <- relativeCradle dir <$> clean_ findCradle + + cradleCurrentDir res `shouldBe` + "test/data/cabal-project/subdir1/subdir2" + + cradleRootDir res `shouldBe` "test/data/cabal-project" + + cradleCabalFile res `shouldBe` + Just ("test/data/cabal-project/cabalapi.cabal") + + let [GlobalDb, sb] = cradlePkgDbStack res + sb `shouldSatisfy` + isPkgDbAt (cwd "test/data/cabal-project/.cabal-sandbox") + + it "works even if a sandbox config file is broken" $ do + withDirectory "test/data/broken-sandbox" $ \dir -> do + res <- relativeCradle dir <$> clean_ findCradle + cradleCurrentDir res `shouldBe` + "test" "data" "broken-sandbox" + + cradleRootDir res `shouldBe` + "test" "data" "broken-sandbox" + + cradleCabalFile res `shouldBe` + Just ("test" "data" "broken-sandbox" "dummy.cabal") + + cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb] diff --git a/test/Dir.hs b/test/Dir.hs index 3e6bae1..e105566 100644 --- a/test/Dir.hs +++ b/test/Dir.hs @@ -1,9 +1,15 @@ -module Dir where +module Dir ( + module Dir + , getCurrentDirectory + , () + ) where import Control.Exception as E import Data.List (isPrefixOf) import System.Directory -import System.FilePath (addTrailingPathSeparator) +import System.FilePath (addTrailingPathSeparator,()) + + withDirectory_ :: FilePath -> IO a -> IO a withDirectory_ dir action = bracket getCurrentDirectory diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs index adfcb32..091bbae 100644 --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -9,51 +9,43 @@ import System.Environment.Executable (getExecutablePath) #else import System.Environment (getExecutablePath) #endif -import System.Exit import System.FilePath -import System.Process import Test.Hspec import TestUtils -import Dir spec :: Spec spec = do describe "types" $ do it "shows types of the expression and its outers" $ do - withDirectory_ "test/data/ghc-mod-check" $ do - res <- runD $ types "Data/Foo.hs" 9 5 - res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" + let tdir = "test/data/ghc-mod-check" + res <- runD' tdir $ types "lib/Data/Foo.hs" 9 5 + res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" it "works with a module using TemplateHaskell" $ do - withDirectory_ "test/data" $ do - res <- runD $ types "Bar.hs" 5 1 - res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] + let tdir = "test/data/template-haskell" + res <- runD' tdir $ types "Bar.hs" 5 1 + res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] it "works with a module that imports another module using TemplateHaskell" $ do - withDirectory_ "test/data" $ do - res <- runD $ types "Main.hs" 3 8 - res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""] + let tdir = "test/data/template-haskell" + res <- runD' tdir $ types "ImportsTH.hs" 3 8 + res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""] describe "info" $ do - it "works for non-export functions" $ do - withDirectory_ "test/data" $ do - res <- runD $ info "Info.hs" "fib" - res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`) + it "works for non exported functions" $ do + let tdir = "test/data/non-exported" + res <- runD' tdir $ info "Fib.hs" "fib" + res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`) it "works with a module using TemplateHaskell" $ do - withDirectory_ "test/data" $ do - res <- runD $ info "Bar.hs" "foo" - res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`) + let tdir = "test/data/template-haskell" + res <- runD' tdir $ info "Bar.hs" "foo" + res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`) it "works with a module that imports another module using TemplateHaskell" $ do - withDirectory_ "test/data" $ do - res <- runD $ info "Main.hs" "bar" - res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`) - - it "doesn't fail on unicode output" $ do - dir <- getDistDir - code <- rawSystem (dir "build/ghc-mod/ghc-mod") ["info", "test/data/Unicode.hs", "Unicode", "unicode"] - code `shouldSatisfy` (== ExitSuccess) + let tdir = "test/data/template-haskell" + res <- runD' tdir $ info "ImportsTH.hs" "bar" + res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`) getDistDir :: IO FilePath getDistDir = takeDirectory . takeDirectory . takeDirectory <$> getExecutablePath diff --git a/test/LintSpec.hs b/test/LintSpec.hs index 26ca952..f451ee4 100644 --- a/test/LintSpec.hs +++ b/test/LintSpec.hs @@ -8,10 +8,10 @@ spec :: Spec spec = do describe "lint" $ do it "can detect a redundant import" $ do - res <- runD $ lint "test/data/hlint.hs" - res `shouldBe` "test/data/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n" + res <- runD $ lint "test/data/hlint/hlint.hs" + res `shouldBe` "test/data/hlint/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n" context "when no suggestions are given" $ do it "doesn't output an empty line" $ do - res <- runD $ lint "test/data/ghc-mod-check/Data/Foo.hs" + res <- runD $ lint "test/data/ghc-mod-check/lib/Data/Foo.hs" res `shouldBe` "" diff --git a/test/Main.hs b/test/Main.hs index 17b3920..8ebe5eb 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -4,6 +4,7 @@ import Dir import Control.Exception as E import Control.Monad (void) +import Data.List import Language.Haskell.GhcMod (debugInfo) import System.Process import Test.Hspec @@ -11,20 +12,35 @@ import TestUtils main :: IO () main = do - let sandboxes = [ "test/data", "test/data/check-packageid" + let sandboxes = [ "test/data/cabal-project" + , "test/data/check-packageid" , "test/data/duplicate-pkgver/" , "test/data/broken-cabal/" ] genSandboxCfg dir = withDirectory dir $ \cwdir -> do system ("sed 's|@CWD@|" ++ cwdir ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config") pkgDirs = - [ "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" + [ "test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" , "test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" , "test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"] genGhcPkgCache dir = system $ "ghc-pkg recache --force -f" ++ dir + genSandboxCfg `mapM_` sandboxes genGhcPkgCache `mapM_` pkgDirs - void $ system "find test \\( -name setup-config -o -name ghc-mod.cache \\) -exec rm {} \\;" + + let caches = [ "setup-config" + , "setup-config.ghc-mod.cabal-ghc-options" + , "setup-config.ghc-mod.cabal-helper.ghc-options" + , "setup-config.ghc-mod.cabal-helper" + , "ghc-mod.cache" + ] + cachesFindExp :: String + cachesFindExp = unwords $ intersperse "-o " $ map ("-name "++) caches + + cleanCmd = "find test \\( "++ cachesFindExp ++" \\) -exec rm {} \\;" + + print cleanCmd + void $ system cleanCmd void $ system "cabal --version" putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal void $ system "ghc --version" diff --git a/test/MonadSpec.hs b/test/MonadSpec.hs index aeae1e0..92cbdb3 100644 --- a/test/MonadSpec.hs +++ b/test/MonadSpec.hs @@ -1,39 +1,17 @@ -{-# LANGUAGE ScopedTypeVariables #-} module MonadSpec where import Test.Hspec -import Dir import TestUtils -import Control.Applicative -import Control.Exception import Control.Monad.Error.Class spec :: Spec spec = do describe "When using GhcModT in a do block" $ it "a pattern match failure causes a call to `fail` on ErrorT in the monad stack" $ do - (a, _) + (a, _h) <- runGhcModT defaultOptions $ do Just _ <- return Nothing return "hello" `catchError` (const $ fail "oh noes") a `shouldBe` (Left $ GMEString "oh noes") - - describe "runGhcModT" $ - it "complains if the cabal file fails to parse while a sandbox is present" $ withDirectory_ "test/data/broken-cabal" $ do - shouldReturnError $ runD' (gmCradle <$> ask) - - describe "gmsGet/Put" $ - it "work" $ do - (runD $ gmsPut (GhcModState Intelligent) >> gmsGet) - `shouldReturn` (GhcModState Intelligent) - - describe "liftIO" $ do - it "converts user errors to GhcModError" $ do - shouldReturnError $ - runD' $ liftIO $ throw (userError "hello") >> return "" - - it "converts a file not found exception to GhcModError" $ do - shouldReturnError $ - runD' $ liftIO $ readFile "/DOES_NOT_EXIST" >> return "" diff --git a/test/PathsAndFilesSpec.hs b/test/PathsAndFilesSpec.hs index cdf1029..760b583 100644 --- a/test/PathsAndFilesSpec.hs +++ b/test/PathsAndFilesSpec.hs @@ -1,10 +1,6 @@ -{-# LANGUAGE CPP #-} module PathsAndFilesSpec where import Language.Haskell.GhcMod.PathsAndFiles -#if __GLASGOW_HASKELL__ <= 706 -import Language.Haskell.GhcMod.GhcPkg -#endif import System.Directory import System.FilePath @@ -14,32 +10,24 @@ import TestUtils spec :: Spec spec = do describe "getSandboxDb" $ do --- ghc < 7.8 -#if __GLASGOW_HASKELL__ <= 706 - it "does include a sandbox with ghc < 7.8" $ do - cwd <- getCurrentDirectory - [GlobalDb, sbPkgDb] <- getPackageDbStack "test/data/" - sbPkgDb `shouldSatisfy` isPkgDbAt (cwd "test/data/.cabal-sandbox") -#endif - it "can parse a config file and extract the sandbox package-db" $ do cwd <- getCurrentDirectory - Just db <- getSandboxDb "test/data/" - db `shouldSatisfy` isPkgDbAt (cwd "test/data/.cabal-sandbox") + Just db <- getSandboxDb "test/data/cabal-project" + db `shouldSatisfy` isPkgDbAt (cwd "test/data/cabal-project/.cabal-sandbox") it "returns Nothing if the sandbox config file is broken" $ do getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing describe "findCabalFile" $ do it "works" $ do - findCabalFile "test/data" `shouldReturn` Just "test/data/cabalapi.cabal" + findCabalFile "test/data/cabal-project" `shouldReturn` Just "test/data/cabal-project/cabalapi.cabal" it "finds cabal files in parent directories" $ do - findCabalFile "test/data/subdir1/subdir2" `shouldReturn` Just "test/data/cabalapi.cabal" + findCabalFile "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just "test/data/cabal-project/cabalapi.cabal" describe "findCabalSandboxDir" $ do it "works" $ do - findCabalSandboxDir "test/data" `shouldReturn` Just "test/data" + findCabalSandboxDir "test/data/cabal-project" `shouldReturn` Just "test/data/cabal-project" it "finds sandboxes in parent directories" $ do - findCabalSandboxDir "test/data/subdir1/subdir2" `shouldReturn` Just "test/data" + findCabalSandboxDir "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just "test/data/cabal-project" diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 180cec9..d2c8132 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -1,11 +1,10 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module TestUtils ( run , runD , runD' - , runI --- , runID - , runIsolatedGhcMod - , isolateCradle + , runE + , runNullLog , shouldReturnError , isPkgDbAt , isPkgConfDAt @@ -13,18 +12,26 @@ module TestUtils ( , module Language.Haskell.GhcMod.Types ) where +import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Types +import Control.Arrow +import Control.Applicative +import Control.Monad (when) +import Control.Monad.Error (ErrorT, runErrorT) +import Control.Monad.Trans.Journal import Data.List.Split +import Data.String import System.FilePath +import System.Directory import Test.Hspec -isolateCradle :: IOish m => GhcModT m a -> GhcModT m a -isolateCradle action = - local modifyEnv $ action - where - modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } } +import Exception + +testLogLevel :: GmLogLevel +testLogLevel = GmException extract :: Show e => IO (Either e a, w) -> IO a extract action = do @@ -33,28 +40,46 @@ extract action = do Right a -> return a Left e -> error $ show e -runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a -runIsolatedGhcMod opt action = do - extract $ runGhcModT opt $ isolateCradle action +withSpecCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a +withSpecCradle cradledir f = + gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f --- | Run GhcMod in isolated cradle with default options ---runID :: GhcModT IO a -> IO a ---runID = runIsolatedGhcMod defaultOptions +withGhcModEnvSpec :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a +withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f --- | Run GhcMod in isolated cradle -runI :: Options -> GhcModT IO a -> IO a -runI = runIsolatedGhcMod +runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog) +runGhcModTSpec opt action = do + dir <- getCurrentDirectory + runGhcModTSpec' dir opt action + +runGhcModTSpec' :: IOish m + => FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog) +runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> + withGhcModEnvSpec dir' opt $ \env -> do + first (fst <$>) <$> runGhcModT'' env defaultGhcModState + (gmSetLogLevel (logLevel opt) >> action) -- | Run GhcMod run :: Options -> GhcModT IO a -> IO a -run opt a = extract $ runGhcModT opt a +run opt a = extract $ runGhcModTSpec opt a -- | Run GhcMod with default options runD :: GhcModT IO a -> IO a -runD = extract . runGhcModT defaultOptions +runD = + extract . runGhcModTSpec defaultOptions { logLevel = testLogLevel } -runD' :: GhcModT IO a -> IO (Either GhcModError a, GhcModLog) -runD' = runGhcModT defaultOptions +runD' :: FilePath -> GhcModT IO a -> IO a +runD' dir = + extract . runGhcModTSpec' dir defaultOptions { logLevel = testLogLevel } + +runE :: ErrorT e IO a -> IO (Either e a) +runE = runErrorT + +runNullLog :: MonadIO m => JournalT GhcModLog m a -> m a +runNullLog action = do + (a,w) <- runJournalT action + when (w /= mempty) $ liftIO $ print w + return a shouldReturnError :: Show a => IO (Either GhcModError a, GhcModLog) @@ -80,3 +105,6 @@ isPkgConfDAt _ _ = False isPkgDbAt :: FilePath -> GhcPkgDb -> Bool isPkgDbAt d (PackageDb dir) = isPkgConfDAt d dir isPkgDbAt _ _ = False + +instance IsString ModuleName where + fromString = mkModuleName diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs index ab2a46a..758b607 100644 --- a/test/UtilsSpec.hs +++ b/test/UtilsSpec.hs @@ -11,13 +11,3 @@ spec = do it "extracts the part of a string surrounded by parentheses" $ do extractParens "asdasdasd ( hello [ world ] )()() kljlkjlkjlk" `shouldBe` "( hello [ world ] )" extractParens "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")][][]" `shouldBe` "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")]" - - describe "liftMonadError" $ do - it "converts IOErrors to GhcModError" $ do - shouldReturnError $ - runD' $ liftIO $ throw (userError "hello") >> return "" - - shouldReturnError $ - runD' $ liftIO $ readFile "/DOES_NOT_EXIST" >> return "" - --- readProcessWithExitCode cmd opts "" diff --git a/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf b/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf deleted file mode 100644 index 4ded8d2..0000000 --- a/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf +++ /dev/null @@ -1,4 +0,0 @@ -name: Cabal -version: 1.18.1.3 -id: Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b -exposed: True diff --git a/test/data/.cabal-sandbox/packages/00-index.cache b/test/data/.cabal-sandbox/packages/00-index.cache deleted file mode 100644 index e69de29..0000000 diff --git a/test/data/.cabal-sandbox/packages/00-index.tar b/test/data/.cabal-sandbox/packages/00-index.tar deleted file mode 100644 index 9df64990f7be3c1f7194a0c22852a1ab3a09f3c5..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 10240 zcmeIu0Sy2E0K%a6Pi+o2h(KY$fB^#r3>YwAz<>b*1`HT5V8DO@0|pEjFkrxd0RsjM P7%*VKfB^#r47?2tC;$Kf diff --git a/test/data/Bar.hs b/test/data/Bar.hs deleted file mode 100644 index d38aaaf..0000000 --- a/test/data/Bar.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Bar (bar) where -import Foo (foo) - -bar = $foo ++ "bar" diff --git a/test/data/Baz.hs b/test/data/Baz.hs deleted file mode 100644 index b199a24..0000000 --- a/test/data/Baz.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Baz (baz) where -import Foo (fooQ) - -baz = [fooQ| foo bar baz |] diff --git a/test/data/Foo.hs b/test/data/Foo.hs deleted file mode 100644 index 3b1bb2f..0000000 --- a/test/data/Foo.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Foo (foo, fooQ) where -import Language.Haskell.TH -import Language.Haskell.TH.Quote (QuasiQuoter(..)) - -foo :: ExpQ -foo = stringE "foo" - -fooQ :: QuasiQuoter -fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined diff --git a/test/data/ForeignExport.hs b/test/data/ForeignExport.hs deleted file mode 100644 index 9a55b96..0000000 --- a/test/data/ForeignExport.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -module ForeignExport where - -import Foreign.C.Types - -foreign export ccall foo :: CUInt - -foo :: CUInt -foo = 123 diff --git a/test/data/Info.hs b/test/data/Info.hs deleted file mode 100644 index 4228f64..0000000 --- a/test/data/Info.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted - -module Info () where - -fib :: Int -> Int -fib 0 = 0 -fib 1 = 1 -fib n = fib (n - 1) + fib (n - 2) diff --git a/test/data/Main.hs b/test/data/Main.hs deleted file mode 100644 index 0fd5838..0000000 --- a/test/data/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Bar (bar) - -main = putStrLn bar diff --git a/test/data/Mutual1.hs b/test/data/Mutual1.hs deleted file mode 100644 index 1b73625..0000000 --- a/test/data/Mutual1.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted - -module Mutual1 where - -import Mutual2 diff --git a/test/data/Mutual2.hs b/test/data/Mutual2.hs deleted file mode 100644 index fb5f593..0000000 --- a/test/data/Mutual2.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Mutual2 where - -import Mutual1 diff --git a/test/data/Unicode.hs b/test/data/Unicode.hs deleted file mode 100644 index f5d1044..0000000 --- a/test/data/Unicode.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Unicode where - -unicode :: α -> α -unicode = id diff --git a/test/data/bad.config b/test/data/bad.config deleted file mode 100644 index 57f89ed..0000000 --- a/test/data/bad.config +++ /dev/null @@ -1 +0,0 @@ -broken diff --git a/test/data/cabal.sandbox.config.in b/test/data/cabal.sandbox.config.in deleted file mode 100644 index 5057c11..0000000 --- a/test/data/cabal.sandbox.config.in +++ /dev/null @@ -1,25 +0,0 @@ --- This is a Cabal package environment file. --- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. --- Please create a 'cabal.config' file in the same directory --- if you want to change the default settings for this sandbox. - - -local-repo: @CWD@/test/data/.cabal-sandbox/packages -logs-dir: @CWD@/test/data/.cabal-sandbox/logs -world-file: @CWD@/test/data/.cabal-sandbox/world -user-install: False -package-db: @CWD@/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d -build-summary: @CWD@/test/data/.cabal-sandbox/logs/build.log - -install-dirs - prefix: @CWD@/test/data/.cabal-sandbox - bindir: $prefix/bin - libdir: $prefix/lib - libsubdir: $arch-$os-$compiler/$pkgid - libexecdir: $prefix/libexec - datadir: $prefix/share - datasubdir: $arch-$os-$compiler/$pkgid - docdir: $datadir/doc/$arch-$os-$compiler/$pkgid - htmldir: $docdir/html - haddockdir: $htmldir - sysconfdir: $prefix/etc diff --git a/test/data/cabalapi.cabal b/test/data/cabalapi.cabal deleted file mode 100644 index 443a25e..0000000 --- a/test/data/cabalapi.cabal +++ /dev/null @@ -1,67 +0,0 @@ -Name: ghc-mod -Version: 1.11.3 -Author: Kazu Yamamoto -Maintainer: Kazu Yamamoto -License: BSD3 -License-File: LICENSE -Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ -Synopsis: Happy Haskell programming on Emacs/Vim -Description: This packages includes Elisp files - and a Haskell command, "ghc-mod". - "ghc*.el" enable completion of - Haskell symbols on Emacs. - Flymake is also integrated. - "ghc-mod" is a backend of "ghc*.el". - It lists up all installed modules - or extracts names of functions, classes, - and data declarations. - To use "ghc-mod" on Vim, - see or - -Category: Development -Cabal-Version: >= 1.6 -Build-Type: Simple -Data-Dir: elisp -Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el - ghc-flymake.el ghc-command.el ghc-info.el - ghc-ins-mod.el ghc-indent.el -Executable ghc-mod - Main-Is: GHCMod.hs - Other-Modules: Browse - CabalApi - Cabal - CabalDev - Check - ErrMsg - Flag - GHCApi - GHCChoice - Gap - Info - Lang - Lint - List - Paths_ghc_mod - Types - GHC-Options: -Wall - Build-Depends: base >= 4.0 && < 5 - , Cabal >= 1.10 - , template-haskell - -Test-Suite spec - Main-Is: Spec.hs - Hs-Source-Dirs: test, . - Type: exitcode-stdio-1.0 - Other-Modules: Expectation - BrowseSpec - CabalApiSpec - FlagSpec - LangSpec - LintSpec - ListSpec - Build-Depends: base >= 4.0 && < 5 - , Cabal >= 1.10 - -Source-Repository head - Type: git - Location: git://github.com/kazu-yamamoto/ghc-mod.git diff --git a/test/data/ghc-mod-check/Data/Foo.hs b/test/data/ghc-mod-check/Data/Foo.hs deleted file mode 100644 index bbb369e..0000000 --- a/test/data/ghc-mod-check/Data/Foo.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Data.Foo where - -foo :: Int -foo = undefined - -fibonacci :: Int -> Integer -fibonacci n = fib 1 0 1 - where - fib m x y - | n == m = y - | otherwise = fib (m+1) y (x + y) diff --git a/test/data/ghc-mod-check/ghc-mod-check.cabal b/test/data/ghc-mod-check/ghc-mod-check.cabal index a9a6eb8..1b82a13 100644 --- a/test/data/ghc-mod-check/ghc-mod-check.cabal +++ b/test/data/ghc-mod-check/ghc-mod-check.cabal @@ -15,8 +15,7 @@ build-type: Simple cabal-version: >=1.8 library - -- exposed-modules: - -- other-modules: + HS-Source-Dirs: lib build-depends: base exposed-modules: Data.Foo diff --git a/test/data/hlint.hs b/test/data/hlint.hs deleted file mode 100644 index b721607..0000000 --- a/test/data/hlint.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Hlist where - -main :: IO () -main = do - putStrLn "Hello, world!" diff --git a/test/data/subdir1/subdir2/dummy b/test/data/subdir1/subdir2/dummy deleted file mode 100644 index 421376d..0000000 --- a/test/data/subdir1/subdir2/dummy +++ /dev/null @@ -1 +0,0 @@ -dummy diff --git a/test/doctests.hs b/test/doctests.hs index b860d45..d46e6ab 100644 --- a/test/doctests.hs +++ b/test/doctests.hs @@ -6,7 +6,7 @@ main :: IO () main = doctest [ "-package" , "ghc" - , "-XConstraintKinds", "-XFlexibleContexts" + , "-XConstraintKinds", "-XFlexibleContexts", "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns" , "-idist/build/autogen/" , "-optP-include" , "-optPdist/build/autogen/cabal_macros.h" From 01dde80385d6598b7db25375b88fb2baadde20a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 5 Mar 2015 16:50:06 +0100 Subject: [PATCH 022/207] Bring test suite up to date --- .travis.yml | 7 +- CabalHelper/Common.hs | 4 +- CabalHelper/Main.hs | 2 +- CabalHelper/Wrapper.hs | 25 ++- Language/Haskell/GhcMod/CabalHelper.hs | 4 +- Language/Haskell/GhcMod/Doc.hs | 8 +- Language/Haskell/GhcMod/Find.hs | 4 +- Language/Haskell/GhcMod/Gap.hs | 32 ++++ Language/Haskell/GhcMod/HomeModuleGraph.hs | 32 +--- Language/Haskell/GhcMod/Monad/Types.hs | 2 +- Language/Haskell/GhcMod/Target.hs | 12 +- Language/Haskell/GhcMod/Utils.hs | 2 +- NotCPP/Declarations.hs | 14 +- ghc-mod.cabal | 8 +- test/CabalHelperSpec.hs | 70 +++++++ test/CheckSpec.hs | 6 +- test/HomeModuleGraphSpec.hs | 180 ++++++++++++++++++ test/TargetSpec.hs | 35 ++++ test/data/annotations/With.hs | 6 + ....1.3-2b161c6bf77657aa17e1681d83cb051b.conf | 4 + .../.cabal-sandbox/packages/00-index.cache | 0 .../.cabal-sandbox/packages/00-index.tar | Bin 0 -> 10240 bytes test/data/cabal-project/Baz.hs | 5 + test/data/cabal-project/Foo.hs | 9 + test/data/cabal-project/Info.hs | 8 + test/data/cabal-project/Main.hs | 3 + .../cabal-project/cabal.sandbox.config.in | 25 +++ test/data/cabal-project/cabalapi.cabal | 67 +++++++ test/data/cabal-project/subdir1/subdir2/dummy | 1 + test/data/foreign-export/ForeignExport.hs | 10 + test/data/ghc-mod-check/lib/Data/Foo.hs | 11 ++ test/data/hlint/hlint.hs | 5 + test/data/home-module-graph/cpp/A.hs | 4 + test/data/home-module-graph/cpp/A1.hs | 4 + test/data/home-module-graph/cpp/A2.hs | 1 + test/data/home-module-graph/cpp/A3.hs | 2 + test/data/home-module-graph/cpp/B.hs | 1 + test/data/home-module-graph/cycle/A.hs | 2 + test/data/home-module-graph/cycle/B.hs | 2 + test/data/home-module-graph/errors/A.hs | 4 + test/data/home-module-graph/errors/A1.hs | 4 + test/data/home-module-graph/errors/A2.hs | 1 + test/data/home-module-graph/errors/A3.hs | 2 + test/data/home-module-graph/errors/B.hs | 1 + .../home-module-graph/indirect-update/A.hs | 4 + .../home-module-graph/indirect-update/A1.hs | 2 + .../home-module-graph/indirect-update/A2.hs | 1 + .../home-module-graph/indirect-update/A3.hs | 2 + .../home-module-graph/indirect-update/B.hs | 1 + .../home-module-graph/indirect-update/C.hs | 1 + test/data/home-module-graph/indirect/A.hs | 4 + test/data/home-module-graph/indirect/A1.hs | 2 + test/data/home-module-graph/indirect/A2.hs | 2 + test/data/home-module-graph/indirect/A3.hs | 2 + test/data/home-module-graph/indirect/B.hs | 1 + test/data/home-module-graph/indirect/C.hs | 1 + test/data/import-cycle/Mutual1.hs | 5 + test/data/import-cycle/Mutual2.hs | 3 + test/data/non-exported/Fib.hs | 8 + test/data/quasi-quotes/FooQ.hs | 6 + test/data/quasi-quotes/QuasiQuotes.hs | 6 + test/data/template-haskell/Bar.hs | 5 + test/data/template-haskell/Foo.hs | 9 + test/data/template-haskell/ImportsTH.hs | 3 + test/doctests.hs | 8 +- 65 files changed, 641 insertions(+), 64 deletions(-) create mode 100644 test/CabalHelperSpec.hs create mode 100644 test/HomeModuleGraphSpec.hs create mode 100644 test/TargetSpec.hs create mode 100644 test/data/annotations/With.hs create mode 100644 test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf create mode 100644 test/data/cabal-project/.cabal-sandbox/packages/00-index.cache create mode 100644 test/data/cabal-project/.cabal-sandbox/packages/00-index.tar create mode 100644 test/data/cabal-project/Baz.hs create mode 100644 test/data/cabal-project/Foo.hs create mode 100644 test/data/cabal-project/Info.hs create mode 100644 test/data/cabal-project/Main.hs create mode 100644 test/data/cabal-project/cabal.sandbox.config.in create mode 100644 test/data/cabal-project/cabalapi.cabal create mode 100644 test/data/cabal-project/subdir1/subdir2/dummy create mode 100644 test/data/foreign-export/ForeignExport.hs create mode 100644 test/data/ghc-mod-check/lib/Data/Foo.hs create mode 100644 test/data/hlint/hlint.hs create mode 100644 test/data/home-module-graph/cpp/A.hs create mode 100644 test/data/home-module-graph/cpp/A1.hs create mode 100644 test/data/home-module-graph/cpp/A2.hs create mode 100644 test/data/home-module-graph/cpp/A3.hs create mode 100644 test/data/home-module-graph/cpp/B.hs create mode 100644 test/data/home-module-graph/cycle/A.hs create mode 100644 test/data/home-module-graph/cycle/B.hs create mode 100644 test/data/home-module-graph/errors/A.hs create mode 100644 test/data/home-module-graph/errors/A1.hs create mode 100644 test/data/home-module-graph/errors/A2.hs create mode 100644 test/data/home-module-graph/errors/A3.hs create mode 100644 test/data/home-module-graph/errors/B.hs create mode 100644 test/data/home-module-graph/indirect-update/A.hs create mode 100644 test/data/home-module-graph/indirect-update/A1.hs create mode 100644 test/data/home-module-graph/indirect-update/A2.hs create mode 100644 test/data/home-module-graph/indirect-update/A3.hs create mode 100644 test/data/home-module-graph/indirect-update/B.hs create mode 100644 test/data/home-module-graph/indirect-update/C.hs create mode 100644 test/data/home-module-graph/indirect/A.hs create mode 100644 test/data/home-module-graph/indirect/A1.hs create mode 100644 test/data/home-module-graph/indirect/A2.hs create mode 100644 test/data/home-module-graph/indirect/A3.hs create mode 100644 test/data/home-module-graph/indirect/B.hs create mode 100644 test/data/home-module-graph/indirect/C.hs create mode 100644 test/data/import-cycle/Mutual1.hs create mode 100644 test/data/import-cycle/Mutual2.hs create mode 100644 test/data/non-exported/Fib.hs create mode 100644 test/data/quasi-quotes/FooQ.hs create mode 100644 test/data/quasi-quotes/QuasiQuotes.hs create mode 100644 test/data/template-haskell/Bar.hs create mode 100644 test/data/template-haskell/Foo.hs create mode 100644 test/data/template-haskell/ImportsTH.hs diff --git a/.travis.yml b/.travis.yml index bb80427..32f4ede 100644 --- a/.travis.yml +++ b/.travis.yml @@ -5,12 +5,13 @@ ghc: - 7.8 install: + - sudo apt-get install zlib1g-dev - cabal update # - ( $CABAL122 && cabal install cabal-install --constraint "Cabal >= 1.22" && ghc-pkg unregister Cabal ) || true - echo $PATH - which cabal - - cabal install happy --constraint 'transformers <= 0.3.0.0' - - cabal install Cabal --constraint "Cabal == $(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | awk -vFS=. '{ print $1 "." $2 }' | tail -n1).*" + - cabal install cabal-install --constraint "Cabal == $(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | awk -vFS=. '{ print $1 "." $2 }' | tail -n1).*" +# - cabal install Cabal --constraint "Cabal == $(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | tail -n1)" - happy --version - cabal install -j --only-dependencies --enable-tests @@ -25,6 +26,8 @@ script: - if [ -n "$(ghc --version | awk '{ print $8 }' | sed -n '/^7.8/p')" ]; then export WERROR="--ghc-option=-Werror"; fi - cabal configure --enable-tests $WERROR - cabal build + - export ghc_mod_libexecdir=$PWD/dist/build/cabal-helper-wrapper + - export ghc_mod_datadir=$PWD - cabal test matrix: diff --git a/CabalHelper/Common.hs b/CabalHelper/Common.hs index 692b373..7c2a2ac 100644 --- a/CabalHelper/Common.hs +++ b/CabalHelper/Common.hs @@ -18,7 +18,7 @@ module CabalHelper.Common where import Control.Applicative -import Control.Exception +import Control.Exception as E import Control.Monad import Data.List import Data.Maybe @@ -40,7 +40,7 @@ panic msg = throw $ Panic msg handlePanic :: IO a -> IO a handlePanic action = - action `catch` \(Panic msg) -> errMsg msg >> exitFailure + action `E.catch` \(Panic msg) -> errMsg msg >> exitFailure errMsg :: String -> IO () errMsg str = do diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs index b5ca210..8838f4d 100644 --- a/CabalHelper/Main.hs +++ b/CabalHelper/Main.hs @@ -114,7 +114,7 @@ main = do errMsg $ "distdir '"++distdir++"' does not exist" exitFailure - v <- maybe silent (const deafening) <$> lookupEnv "GHC_MOD_DEBUG" + v <- maybe silent (const deafening) . lookup "GHC_MOD_DEBUG" <$> getEnvironment lbi <- unsafeInterleaveIO $ getPersistBuildConfig distdir let pd = localPkgDescr lbi diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs index 9c460ab..25f698c 100644 --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -19,6 +19,7 @@ module Main where import Control.Applicative import Control.Arrow +import Control.Exception as E import Control.Monad import Control.Monad.Trans.Maybe import Data.Char @@ -133,7 +134,8 @@ compileHelper cabalVer = do else do -- otherwise compile the requested cabal version into an isolated -- package-db - db <- installCabal cabalVer + db <- installCabal cabalVer `E.catch` + \(SomeException _) -> errorInstallCabal cabalVer compileWithPkg chdir (Just db) Just _ -> compileWithPkg chdir Nothing @@ -149,12 +151,27 @@ compileHelper cabalVer = do -- errorNoCabal :: Version -> a -- errorNoCabal cabalVer = panic $ printf "\ --- \No appropriate Cabal package found, wanted version %s.\n\ --- \- Check output of: $ ghc-pkg list Cabal\n\ --- \- Maybe try: $ cabal install Cabal --constraint 'Cabal == %s'" sver sver +-- \No appropriate Cabal package found, wanted version %s.\n" -- where -- sver = showVersion cabalVer +errorInstallCabal :: Version -> a +errorInstallCabal cabalVer = panic $ printf "\ +\Installing Cabal version %s failed.\n\ +\n\ +\You have two choices now:\n\ +\- Either you install this version of Cabal in your globa/luser package-db\n\ +\ somehow\n\ +\n\ +\- Or you can see if you can update your cabal-install to use a different\n\ +\ version of the Cabal library that we can build with:\n\ +\ $ cabal install cabal-install --constraint 'Cabal > %s'\n\ +\n\ +\To check the version cabal-install is currently using try:\n\ +\ $ cabal --version\n" sver sver + where + sver = showVersion cabalVer + errorNoMain :: FilePath -> a errorNoMain datadir = panic $ printf "\ \Could not find $datadir/CabalHelper/Main.hs!\n\ diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index c98bd63..0f83443 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -29,7 +29,7 @@ import Data.Monoid import Data.List import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.Error as E import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World import Language.Haskell.GhcMod.PathsAndFiles @@ -93,7 +93,7 @@ cabalHelper = withCabal $ do res <- liftIO $ cached cradleRootDir (cabalHelperCache cmds) $ do out <- readProcess exe (distdir:cmds) "" - evaluate (read out) `catch` + evaluate (read out) `E.catch` \(SomeException _) -> error "cabalHelper: read failed" let [ Just (GmCabalHelperEntrypoints eps), diff --git a/Language/Haskell/GhcMod/Doc.hs b/Language/Haskell/GhcMod/Doc.hs index 5fa485c..823e19b 100644 --- a/Language/Haskell/GhcMod/Doc.hs +++ b/Language/Haskell/GhcMod/Doc.hs @@ -11,10 +11,10 @@ showPage dflag style = showDocWith dflag PageMode . withStyle dflag style showOneLine :: DynFlags -> PprStyle -> SDoc -> String showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style -showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String -showForUser dflags unqual sdoc = - showDocWith dflags PageMode $ - runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay +-- showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String +-- showForUser dflags unqual sdoc = +-- showDocWith dflags PageMode $ +-- runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay getStyle :: GhcMonad m => m PprStyle getStyle = do diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 452b29c..87fe3c6 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -38,8 +38,8 @@ import System.IO #endif #if MIN_VERSION_containers(0,5,0) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M +import Data.Map (Map) +import qualified Data.Map as M #else import Data.Map (Map) import qualified Data.Map as M diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index f5fbd3f..eab83d0 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -39,6 +39,7 @@ module Language.Haskell.GhcMod.Gap ( , listVisibleModuleNames , listVisibleModules , Language.Haskell.GhcMod.Gap.isSynTyCon + , parseModuleHeader ) where import Control.Applicative hiding (empty) @@ -96,6 +97,13 @@ import PackageConfig (PackageConfig, packageConfigId) import qualified Data.IntSet as I (IntSet, empty) #endif + +import Bag +import Lexer as L +import Parser +import SrcLoc + + ---------------------------------------------------------------- ---------------------------------------------------------------- -- @@ -487,3 +495,27 @@ isSynTyCon = GHC.isTypeSynonymTyCon #else isSynTyCon = GHC.isSynTyCon #endif + + +parseModuleHeader + :: String -- ^ Haskell module source text (full Unicode is supported) + -> DynFlags + -> FilePath -- ^ the filename (for source locations) + -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) +parseModuleHeader str dflags filename = + let + loc = mkRealSrcLoc (mkFastString filename) 1 1 + buf = stringToStringBuffer str + in + case L.unP Parser.parseHeader (mkPState dflags buf loc) of + + PFailed sp err -> +#if __GLASGOW_HASKELL__ >= 706 + Left (unitBag (mkPlainErrMsg dflags sp err)) +#else + Left (unitBag (mkPlainErrMsg sp err)) +#endif + + POk pst rdr_module -> + let (warns,_) = getMessages pst in + Right (warns, rdr_module) diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index f15afc1..442a108 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -30,19 +30,13 @@ module Language.Haskell.GhcMod.HomeModuleGraph ( , moduleGraphToDot ) where -import Bag -import DriverPipeline hiding (unP) +import DriverPipeline import ErrUtils import Exception -import FastString import Finder import GHC import HscTypes -import Lexer import MonadUtils hiding (foldrM) -import Parser -import SrcLoc -import StringBuffer import Control.Arrow ((&&&)) import Control.Monad @@ -51,8 +45,8 @@ import Control.Monad.State.Strict (execStateT) import Control.Monad.State.Class import Data.Maybe import Data.Monoid -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Map (Map) +import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import System.FilePath @@ -61,6 +55,7 @@ import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Gap (parseModuleHeader) -- | Turn module graph into a graphviz dot file -- @@ -249,22 +244,3 @@ fileModuleName env fn = handle (\(_ :: SomeException) -> return $ Right Nothing) Right (_, lmdl) -> do let HsModule {..} = unLoc lmdl return $ Right $ unLoc <$> hsmodName - -parseModuleHeader - :: String -- ^ Haskell module source text (full Unicode is supported) - -> DynFlags - -> FilePath -- ^ the filename (for source locations) - -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) -parseModuleHeader str dflags filename = - let - loc = mkRealSrcLoc (mkFastString filename) 1 1 - buf = stringToStringBuffer str - in - case unP Parser.parseHeader (mkPState dflags buf loc) of - - PFailed sp err -> - Left (unitBag (mkPlainErrMsg dflags sp err)) - - POk pst rdr_module -> - let (warns,_) = getMessages pst in - Right (warns, rdr_module) diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 5ad2f6f..e4c18cb 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -17,7 +17,7 @@ {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} {-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-} -{-# LANGUAGE StandaloneDeriving, InstanceSigs #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.Monad.Types ( diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 51a3ba4..2fb085e 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -36,13 +36,14 @@ import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Utils import Data.Maybe import Data.Either import Data.Foldable (foldrM) import Data.IORef -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Map (Map) +import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set @@ -51,8 +52,7 @@ import System.FilePath withLightHscEnv :: forall m a. IOish m => [GHCOption] -> (HscEnv -> m a) -> m a -withLightHscEnv opts action = gbracket initEnv teardownEnv (action) - +withLightHscEnv opts action = gbracket initEnv teardownEnv action where teardownEnv :: HscEnv -> m () teardownEnv env = liftIO $ do @@ -241,7 +241,7 @@ resolveEntrypoints env srcDirs ms = resolve :: Either FilePath ModuleName -> IO (Maybe ModulePath) resolve (Right mn) = findModulePath env mn resolve (Left fn') = do - mfn <- findFile srcDirs fn' + mfn <- findFile' srcDirs fn' case mfn of Nothing -> return Nothing Just fn'' -> do @@ -253,6 +253,8 @@ resolveEntrypoints env srcDirs ms = case mmn of Nothing -> mkMainModulePath fn Just mn -> ModulePath mn fn + findFile' dirs file = + mconcat <$> mapM (mightExist . (file)) dirs resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m) => Maybe [Either FilePath ModuleName] diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 938b037..c39037b 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -128,7 +128,7 @@ libexecNotExitsError exe dir = printf tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath) tryFindGhcModTreeLibexecDir = do - exe <- getExecutablePath + exe <- getExecutablePath' dir <- case takeFileName exe of "ghc" -> do -- we're probably in ghci; try CWD getCurrentDirectory diff --git a/NotCPP/Declarations.hs b/NotCPP/Declarations.hs index 02fb48f..1657a68 100644 --- a/NotCPP/Declarations.hs +++ b/NotCPP/Declarations.hs @@ -22,7 +22,7 @@ module NotCPP.Declarations where import Control.Arrow import Control.Applicative import Data.Maybe -import Language.Haskell.TH.Syntax hiding (lookupName) +import Language.Haskell.TH.Syntax import NotCPP.LookupValueName @@ -39,10 +39,10 @@ recUpdE' :: Q Exp -> Name -> Exp -> Q Exp recUpdE' ex name assign = do RecUpdE <$> ex <*> pure [(name, assign)] -lookupName :: (NameSpace, String) -> Q (Maybe Name) -lookupName (VarName, n) = lookupValueName n -lookupName (DataName, n) = lookupValueName n -lookupName (TcClsName, n) = lookupTypeName n +lookupName' :: (NameSpace, String) -> Q (Maybe Name) +lookupName' (VarName, n) = lookupValueName n +lookupName' (DataName, n) = lookupValueName n +lookupName' (TcClsName, n) = lookupTypeName n -- Does this even make sense? ifelseD :: Q [Dec] -> Q [Dec] -> Q [Dec] @@ -90,14 +90,16 @@ ifD decls' = do _ -> return []) definedNames :: [(NameSpace, Name)] -> Q [Name] -definedNames ns = catMaybes <$> (lookupName . second nameBase) `mapM` ns +definedNames ns = catMaybes <$> (lookupName' . second nameBase) `mapM` ns boundNames :: Dec -> [(NameSpace, Name)] boundNames decl = case decl of SigD n _ -> [(VarName, n)] FunD n _cls -> [(VarName, n)] +#if __GLASGOW_HASKELL__ >= 706 InfixD _ n -> [(VarName, n)] +#endif ValD p _ _ -> map ((,) VarName) $ patNames p TySynD n _ _ -> [(TcClsName, n)] diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 3c81496..065e7ea 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -37,6 +37,7 @@ Extra-Source-Files: ChangeLog test/data/cabal-flags/cabal-flags.cabal test/data/cabal-project/*.cabal test/data/cabal-project/*.hs + test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf test/data/cabal-project/cabal.sandbox.config.in test/data/cabal-project/subdir1/subdir2/dummy test/data/case-split/*.hs @@ -44,6 +45,8 @@ Extra-Source-Files: ChangeLog test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf test/data/check-test-subdir/*.cabal test/data/check-test-subdir/src/Check/Test/*.hs + test/data/check-test-subdir/test/*.hs + test/data/check-test-subdir/test/Bar/*.hs test/data/duplicate-pkgver/cabal.sandbox.config.in test/data/duplicate-pkgver/duplicate-pkgver.cabal test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-1.0-7c59d13f32294d1ef6dc6233c24df961.conf @@ -195,9 +198,10 @@ Executable cabal-helper-wrapper , bytestring , binary , containers - , Cabal >= 1.16 + , Cabal >= 1.14 , directory , filepath + , old-time , process , transformers , template-haskell @@ -210,6 +214,8 @@ Test-Suite doctest Ghc-Options: -Wall Default-Extensions: ConstraintKinds, FlexibleContexts Main-Is: doctests.hs + if impl(ghc == 7.4.*) + Buildable: False Build-Depends: base , doctest >= 0.9.3 diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs new file mode 100644 index 0000000..fd1c4d4 --- /dev/null +++ b/test/CabalHelperSpec.hs @@ -0,0 +1,70 @@ +module CabalHelperSpec where + +import Control.Arrow +import Control.Applicative +import Language.Haskell.GhcMod.CabalHelper +import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.Error +import Test.Hspec +import System.Directory +import System.FilePath +import System.Process (readProcess) + +import Dir +import TestUtils +import Data.List + +import Config (cProjectVersionInt) + +ghcVersion :: Int +ghcVersion = read cProjectVersionInt + +gmeProcessException :: GhcModError -> Bool +gmeProcessException GMEProcess {} = True +gmeProcessException _ = False + +pkgOptions :: [String] -> [String] +pkgOptions [] = [] +pkgOptions (_:[]) = [] +pkgOptions (x:y:xs) | x == "-package-id" = [name y] ++ pkgOptions xs + | otherwise = pkgOptions (y:xs) + where + stripDash s = maybe s id $ (flip drop s . (+1) <$> findIndex (=='-') s) + name s = reverse $ stripDash $ stripDash $ reverse s + +idirOpts :: [(c, [String])] -> [(c, [String])] +idirOpts = map (second $ map (drop 2) . filter ("-i"`isPrefixOf`)) + +spec :: Spec +spec = do + describe "getGhcOptions" $ do + it "throws an exception if the cabal file is broken" $ do + let tdir = "test/data/broken-caba" + runD' tdir getGhcOptions `shouldThrow` anyIOException + + it "handles sandboxes correctly" $ do + let tdir = "test/data/cabal-project" + cwd <- getCurrentDirectory + + opts <- runD' tdir getGhcOptions + + if ghcVersion < 706 + then forM_ opts (\(_, o) -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) + else forM_ opts (\(_, o) -> o `shouldContain` ["-no-user-package-db","-package-db",cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) + + it "extracts build dependencies" $ do + let tdir = "test/data/cabal-project" + opts <- runD' tdir getGhcOptions + let ghcOpts = snd $ head opts + pkgs = pkgOptions ghcOpts + pkgs `shouldBe` ["Cabal","base","template-haskell"] + + it "uses non default flags" $ do + let tdir = "test/data/cabal-flags" + _ <- withDirectory_ tdir $ + readProcess "cabal" ["configure", "-ftest-flag"] "" + + opts <- runD' tdir getGhcOptions + let ghcOpts = snd $ head opts + pkgs = pkgOptions ghcOpts + pkgs `shouldBe` ["Cabal","base"] diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index 75fb9f0..f240f98 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} module CheckSpec where -import Data.List (isInfixOf, isPrefixOf) --isSuffixOf, import Language.Haskell.GhcMod ---import System.FilePath + +import Data.List +import System.Process import Test.Hspec import TestUtils @@ -20,6 +21,7 @@ spec = do it "works even if a module imports another module from a different directory" $ do withDirectory_ "test/data/check-test-subdir" $ do + _ <- system "cabal configure --enable-tests" res <- runD $ checkSyntax ["test/Bar/Baz.hs"] res `shouldSatisfy` (("test" "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`) diff --git a/test/HomeModuleGraphSpec.hs b/test/HomeModuleGraphSpec.hs new file mode 100644 index 0000000..b4640d1 --- /dev/null +++ b/test/HomeModuleGraphSpec.hs @@ -0,0 +1,180 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings #-} + +module HomeModuleGraphSpec where + +import Language.Haskell.GhcMod.HomeModuleGraph +import Language.Haskell.GhcMod.Target +import TestUtils + +import GHC +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Maybe + +import Test.Hspec + +runAGhc :: [GHCOption] -> (HscEnv -> LightGhc a) -> IO a +runAGhc opts action = withLightHscEnv opts $ \env -> do + runLightGhc env $ getSession >>= action + +hmGraph :: FilePath -> [String] -> String -> IO GmModuleGraph +hmGraph dir opts mn = runAGhc opts $ \env -> liftIO $ do + runD' dir $ do + smp <- liftIO $ findModulePathSet env [mkModuleName mn] + homeModuleGraph env smp + +uhmGraph :: FilePath -> [String] -> String -> String -> GmModuleGraph -> IO GmModuleGraph +uhmGraph dir opts mn umn g = runAGhc opts $ \env -> liftIO $ do + runD' dir $ do + smp <- liftIO $ findModulePathSet env [mkModuleName mn] + usmp <- liftIO $ findModulePathSet env [mkModuleName umn] + updateHomeModuleGraph env g smp usmp + +mapMap :: (Ord k, Ord k') + => (k -> k') -> (a -> a') -> Map.Map k a -> Map.Map k' a' +mapMap fk fa = Map.mapKeys fk . Map.map fa + +mapMpFn :: (FilePath -> FilePath) -> ModulePath -> ModulePath +mapMpFn f (ModulePath mn fn) = ModulePath mn (f fn) + +mp :: ModuleName -> ModulePath +mp mn = ModulePath mn $ moduleNameString mn ++ ".hs" + +spec :: Spec +spec = do + describe "reachable" $ do + let + smp = + Set.fromList + [ mp "A" + , mp "B" + , mp "C" + , mp "D" + , mp "E" + , mp "F" + , mp "G" + , mp "H" + , mp "I" + ] + fileMap = mkFileMap smp + moduleMap = mkModuleMap smp + + completeGraph = + Map.map (Set.map lookupMM) . Map.mapKeys lookupMM + + lookupMM = fromJust . flip Map.lookup moduleMap + + graph = completeGraph $ + Map.fromList + [ ("A", Set.fromList ["B"]) + , ("B", Set.fromList ["C", "D"]) + , ("C", Set.fromList ["F"]) + , ("D", Set.fromList ["E"]) + , ("E", Set.fromList []) + , ("F", Set.fromList []) + , ("G", Set.fromList []) + , ("H", Set.fromList []) + , ("I", Set.fromList []) + ] + + really_reachable = + Set.fromList + [ mp "A" + , mp "B" + , mp "C" + , mp "D" + , mp "E" + , mp "F" + ] + + g = GmModuleGraph { + gmgFileMap = fileMap, + gmgModuleMap = moduleMap, + gmgGraph = graph + } + + it "reachable Set.empty g == Set.empty" $ do + reachable Set.empty g `shouldBe` Set.empty + + it "lists only reachable nodes" $ do + reachable (Set.fromList [mp "A"]) g `shouldBe` really_reachable + + + describe "homeModuleGraph" $ do + it "cycles don't break it" $ do + let tdir = "test/data/home-module-graph/cycle" + g <- hmGraph tdir [] "A" + gmgGraph g `shouldBe` + Map.fromList + [ (mp "A", Set.fromList [mp "B"]) + , (mp "B", Set.fromList [mp "A"]) + ] + + it "follows imports" $ do + let tdir = "test/data/home-module-graph/indirect" + g <- hmGraph tdir [] "A" + gmgGraph g `shouldBe` + Map.fromList + [ (mp "A", Set.fromList [mp "A1", mp "A2", mp "A3"]) + , (mp "A1", Set.fromList [mp "B"]) + , (mp "A2", Set.fromList [mp "C"]) + , (mp "A3", Set.fromList [mp "B"]) + , (mp "B", Set.fromList []) + , (mp "C", Set.fromList []) + ] + + it "returns partial results on parse errors" $ do + let tdir = "test/data/home-module-graph/errors" + g <- hmGraph tdir [] "A" + gmgGraph g `shouldBe` + Map.fromList + [ (mp "A", Set.fromList [mp "A1", mp "A2", mp "A3"]) + , (mp "A1", Set.fromList []) -- parse error here + , (mp "A2", Set.fromList []) + , (mp "A3", Set.fromList [mp "B"]) + , (mp "B", Set.fromList []) + ] + + it "returns partial results on CPP errors" $ do + let tdir = "test/data/home-module-graph/cpp" + g <- hmGraph tdir [] "A" + gmgGraph g `shouldBe` + Map.fromList + [ (mp "A", Set.fromList [mp "A1", mp "A2", mp "A3"]) + , (mp "A1", Set.fromList []) -- CPP error here + , (mp "A2", Set.fromList []) + , (mp "A3", Set.fromList [mp "B"]) + , (mp "B", Set.fromList []) + ] + + describe "updateHomeModuleGraph" $ do + it "removes unreachable nodes" $ do + let tdir = "test/data/home-module-graph/indirect" + let tdir' = "test/data/home-module-graph/indirect-update" + ig <- hmGraph tdir [] "A" + g <- uhmGraph tdir' [] "A" "A2" ig + gmgGraph g `shouldBe` + Map.fromList + [ (mp "A", Set.fromList [mp "A1", mp "A2", mp "A3"]) + , (mp "A1", Set.fromList [mp "B"]) + , (mp "A2", Set.fromList []) + , (mp "A3", Set.fromList [mp "B"]) + , (mp "B", Set.fromList []) + -- C was removed + ] diff --git a/test/TargetSpec.hs b/test/TargetSpec.hs new file mode 100644 index 0000000..8429621 --- /dev/null +++ b/test/TargetSpec.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +module TargetSpec where + +import Language.Haskell.GhcMod.Target +import Language.Haskell.GhcMod.Gap +import Test.Hspec + +import TestUtils + +import GHC +import Data.List +import Data.Maybe + +spec :: Spec +spec = do + describe "runLightGhc" $ do + it "works at all" $ do + withLightHscEnv [] $ \env -> + runLightGhc env (return ()) `shouldReturn` () + + it "has modules in scope" $ do + withLightHscEnv [] $ \env -> + runLightGhc env $ do + dflags <- getSessionDynFlags + let i = intersect (listVisibleModuleNames dflags) + ["Control.Applicative", "Control.Arrow" + ,"Control.Exception", "GHC.Exts", "GHC.Float"] + liftIO $ i `shouldSatisfy` not . null + + it "can get module info" $ do + withLightHscEnv [] $ \env -> + runLightGhc env $ do + mdl <- findModule "Data.List" Nothing + mmi <- getModuleInfo mdl + liftIO $ isJust mmi `shouldBe` True diff --git a/test/data/annotations/With.hs b/test/data/annotations/With.hs new file mode 100644 index 0000000..68bd38c --- /dev/null +++ b/test/data/annotations/With.hs @@ -0,0 +1,6 @@ +module Main where + +{-# ANN module ["this", "can", "be", "anything"] #-} + +main :: IO () +main = putStrLn "Hello world!" diff --git a/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf b/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf new file mode 100644 index 0000000..4ded8d2 --- /dev/null +++ b/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf @@ -0,0 +1,4 @@ +name: Cabal +version: 1.18.1.3 +id: Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b +exposed: True diff --git a/test/data/cabal-project/.cabal-sandbox/packages/00-index.cache b/test/data/cabal-project/.cabal-sandbox/packages/00-index.cache new file mode 100644 index 0000000..e69de29 diff --git a/test/data/cabal-project/.cabal-sandbox/packages/00-index.tar b/test/data/cabal-project/.cabal-sandbox/packages/00-index.tar new file mode 100644 index 0000000000000000000000000000000000000000..9df64990f7be3c1f7194a0c22852a1ab3a09f3c5 GIT binary patch literal 10240 zcmeIu0Sy2E0K%a6Pi+o2h(KY$fB^#r3>YwAz<>b*1`HT5V8DO@0|pEjFkrxd0RsjM P7%*VKfB^#r47?2tC;$Kf literal 0 HcmV?d00001 diff --git a/test/data/cabal-project/Baz.hs b/test/data/cabal-project/Baz.hs new file mode 100644 index 0000000..b199a24 --- /dev/null +++ b/test/data/cabal-project/Baz.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} +module Baz (baz) where +import Foo (fooQ) + +baz = [fooQ| foo bar baz |] diff --git a/test/data/cabal-project/Foo.hs b/test/data/cabal-project/Foo.hs new file mode 100644 index 0000000..3b1bb2f --- /dev/null +++ b/test/data/cabal-project/Foo.hs @@ -0,0 +1,9 @@ +module Foo (foo, fooQ) where +import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter(..)) + +foo :: ExpQ +foo = stringE "foo" + +fooQ :: QuasiQuoter +fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined diff --git a/test/data/cabal-project/Info.hs b/test/data/cabal-project/Info.hs new file mode 100644 index 0000000..4228f64 --- /dev/null +++ b/test/data/cabal-project/Info.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted + +module Info () where + +fib :: Int -> Int +fib 0 = 0 +fib 1 = 1 +fib n = fib (n - 1) + fib (n - 2) diff --git a/test/data/cabal-project/Main.hs b/test/data/cabal-project/Main.hs new file mode 100644 index 0000000..0fd5838 --- /dev/null +++ b/test/data/cabal-project/Main.hs @@ -0,0 +1,3 @@ +import Bar (bar) + +main = putStrLn bar diff --git a/test/data/cabal-project/cabal.sandbox.config.in b/test/data/cabal-project/cabal.sandbox.config.in new file mode 100644 index 0000000..79c39e4 --- /dev/null +++ b/test/data/cabal-project/cabal.sandbox.config.in @@ -0,0 +1,25 @@ +-- This is a Cabal package environment file. +-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. +-- Please create a 'cabal.config' file in the same directory +-- if you want to change the default settings for this sandbox. + + +local-repo: @CWD@/test/data/cabal-project/.cabal-sandbox/packages +logs-dir: @CWD@/test/data/cabal-project/.cabal-sandbox/logs +world-file: @CWD@/test/data/cabal-project/.cabal-sandbox/world +user-install: False +package-db: @CWD@/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d +build-summary: @CWD@/test/data/cabal-project/.cabal-sandbox/logs/build.log + +install-dirs + prefix: @CWD@/test/data/cabal-project/.cabal-sandbox + bindir: $prefix/bin + libdir: $prefix/lib + libsubdir: $arch-$os-$compiler/$pkgid + libexecdir: $prefix/libexec + datadir: $prefix/share + datasubdir: $arch-$os-$compiler/$pkgid + docdir: $datadir/doc/$arch-$os-$compiler/$pkgid + htmldir: $docdir/html + haddockdir: $htmldir + sysconfdir: $prefix/etc diff --git a/test/data/cabal-project/cabalapi.cabal b/test/data/cabal-project/cabalapi.cabal new file mode 100644 index 0000000..443a25e --- /dev/null +++ b/test/data/cabal-project/cabalapi.cabal @@ -0,0 +1,67 @@ +Name: ghc-mod +Version: 1.11.3 +Author: Kazu Yamamoto +Maintainer: Kazu Yamamoto +License: BSD3 +License-File: LICENSE +Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ +Synopsis: Happy Haskell programming on Emacs/Vim +Description: This packages includes Elisp files + and a Haskell command, "ghc-mod". + "ghc*.el" enable completion of + Haskell symbols on Emacs. + Flymake is also integrated. + "ghc-mod" is a backend of "ghc*.el". + It lists up all installed modules + or extracts names of functions, classes, + and data declarations. + To use "ghc-mod" on Vim, + see or + +Category: Development +Cabal-Version: >= 1.6 +Build-Type: Simple +Data-Dir: elisp +Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el + ghc-flymake.el ghc-command.el ghc-info.el + ghc-ins-mod.el ghc-indent.el +Executable ghc-mod + Main-Is: GHCMod.hs + Other-Modules: Browse + CabalApi + Cabal + CabalDev + Check + ErrMsg + Flag + GHCApi + GHCChoice + Gap + Info + Lang + Lint + List + Paths_ghc_mod + Types + GHC-Options: -Wall + Build-Depends: base >= 4.0 && < 5 + , Cabal >= 1.10 + , template-haskell + +Test-Suite spec + Main-Is: Spec.hs + Hs-Source-Dirs: test, . + Type: exitcode-stdio-1.0 + Other-Modules: Expectation + BrowseSpec + CabalApiSpec + FlagSpec + LangSpec + LintSpec + ListSpec + Build-Depends: base >= 4.0 && < 5 + , Cabal >= 1.10 + +Source-Repository head + Type: git + Location: git://github.com/kazu-yamamoto/ghc-mod.git diff --git a/test/data/cabal-project/subdir1/subdir2/dummy b/test/data/cabal-project/subdir1/subdir2/dummy new file mode 100644 index 0000000..421376d --- /dev/null +++ b/test/data/cabal-project/subdir1/subdir2/dummy @@ -0,0 +1 @@ +dummy diff --git a/test/data/foreign-export/ForeignExport.hs b/test/data/foreign-export/ForeignExport.hs new file mode 100644 index 0000000..9a55b96 --- /dev/null +++ b/test/data/foreign-export/ForeignExport.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module ForeignExport where + +import Foreign.C.Types + +foreign export ccall foo :: CUInt + +foo :: CUInt +foo = 123 diff --git a/test/data/ghc-mod-check/lib/Data/Foo.hs b/test/data/ghc-mod-check/lib/Data/Foo.hs new file mode 100644 index 0000000..bbb369e --- /dev/null +++ b/test/data/ghc-mod-check/lib/Data/Foo.hs @@ -0,0 +1,11 @@ +module Data.Foo where + +foo :: Int +foo = undefined + +fibonacci :: Int -> Integer +fibonacci n = fib 1 0 1 + where + fib m x y + | n == m = y + | otherwise = fib (m+1) y (x + y) diff --git a/test/data/hlint/hlint.hs b/test/data/hlint/hlint.hs new file mode 100644 index 0000000..b721607 --- /dev/null +++ b/test/data/hlint/hlint.hs @@ -0,0 +1,5 @@ +module Hlist where + +main :: IO () +main = do + putStrLn "Hello, world!" diff --git a/test/data/home-module-graph/cpp/A.hs b/test/data/home-module-graph/cpp/A.hs new file mode 100644 index 0000000..e4f573e --- /dev/null +++ b/test/data/home-module-graph/cpp/A.hs @@ -0,0 +1,4 @@ +module A where +import A1 +import A2 +import A3 diff --git a/test/data/home-module-graph/cpp/A1.hs b/test/data/home-module-graph/cpp/A1.hs new file mode 100644 index 0000000..82f6066 --- /dev/null +++ b/test/data/home-module-graph/cpp/A1.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} +module A1 where +#elif +import B diff --git a/test/data/home-module-graph/cpp/A2.hs b/test/data/home-module-graph/cpp/A2.hs new file mode 100644 index 0000000..bcf1470 --- /dev/null +++ b/test/data/home-module-graph/cpp/A2.hs @@ -0,0 +1 @@ +module A2 where diff --git a/test/data/home-module-graph/cpp/A3.hs b/test/data/home-module-graph/cpp/A3.hs new file mode 100644 index 0000000..616ba75 --- /dev/null +++ b/test/data/home-module-graph/cpp/A3.hs @@ -0,0 +1,2 @@ +module A3 where +import B diff --git a/test/data/home-module-graph/cpp/B.hs b/test/data/home-module-graph/cpp/B.hs new file mode 100644 index 0000000..c759bc2 --- /dev/null +++ b/test/data/home-module-graph/cpp/B.hs @@ -0,0 +1 @@ +module B where diff --git a/test/data/home-module-graph/cycle/A.hs b/test/data/home-module-graph/cycle/A.hs new file mode 100644 index 0000000..f7e8963 --- /dev/null +++ b/test/data/home-module-graph/cycle/A.hs @@ -0,0 +1,2 @@ +module A where +import B diff --git a/test/data/home-module-graph/cycle/B.hs b/test/data/home-module-graph/cycle/B.hs new file mode 100644 index 0000000..af11916 --- /dev/null +++ b/test/data/home-module-graph/cycle/B.hs @@ -0,0 +1,2 @@ +module B where +import A diff --git a/test/data/home-module-graph/errors/A.hs b/test/data/home-module-graph/errors/A.hs new file mode 100644 index 0000000..e4f573e --- /dev/null +++ b/test/data/home-module-graph/errors/A.hs @@ -0,0 +1,4 @@ +module A where +import A1 +import A2 +import A3 diff --git a/test/data/home-module-graph/errors/A1.hs b/test/data/home-module-graph/errors/A1.hs new file mode 100644 index 0000000..422e841 --- /dev/null +++ b/test/data/home-module-graph/errors/A1.hs @@ -0,0 +1,4 @@ +module A1 where +psogduapzsü9 +import B +lxäö,vLMCks diff --git a/test/data/home-module-graph/errors/A2.hs b/test/data/home-module-graph/errors/A2.hs new file mode 100644 index 0000000..bcf1470 --- /dev/null +++ b/test/data/home-module-graph/errors/A2.hs @@ -0,0 +1 @@ +module A2 where diff --git a/test/data/home-module-graph/errors/A3.hs b/test/data/home-module-graph/errors/A3.hs new file mode 100644 index 0000000..616ba75 --- /dev/null +++ b/test/data/home-module-graph/errors/A3.hs @@ -0,0 +1,2 @@ +module A3 where +import B diff --git a/test/data/home-module-graph/errors/B.hs b/test/data/home-module-graph/errors/B.hs new file mode 100644 index 0000000..c759bc2 --- /dev/null +++ b/test/data/home-module-graph/errors/B.hs @@ -0,0 +1 @@ +module B where diff --git a/test/data/home-module-graph/indirect-update/A.hs b/test/data/home-module-graph/indirect-update/A.hs new file mode 100644 index 0000000..e4f573e --- /dev/null +++ b/test/data/home-module-graph/indirect-update/A.hs @@ -0,0 +1,4 @@ +module A where +import A1 +import A2 +import A3 diff --git a/test/data/home-module-graph/indirect-update/A1.hs b/test/data/home-module-graph/indirect-update/A1.hs new file mode 100644 index 0000000..3b7e310 --- /dev/null +++ b/test/data/home-module-graph/indirect-update/A1.hs @@ -0,0 +1,2 @@ +module A1 where +import B diff --git a/test/data/home-module-graph/indirect-update/A2.hs b/test/data/home-module-graph/indirect-update/A2.hs new file mode 100644 index 0000000..bcf1470 --- /dev/null +++ b/test/data/home-module-graph/indirect-update/A2.hs @@ -0,0 +1 @@ +module A2 where diff --git a/test/data/home-module-graph/indirect-update/A3.hs b/test/data/home-module-graph/indirect-update/A3.hs new file mode 100644 index 0000000..616ba75 --- /dev/null +++ b/test/data/home-module-graph/indirect-update/A3.hs @@ -0,0 +1,2 @@ +module A3 where +import B diff --git a/test/data/home-module-graph/indirect-update/B.hs b/test/data/home-module-graph/indirect-update/B.hs new file mode 100644 index 0000000..c759bc2 --- /dev/null +++ b/test/data/home-module-graph/indirect-update/B.hs @@ -0,0 +1 @@ +module B where diff --git a/test/data/home-module-graph/indirect-update/C.hs b/test/data/home-module-graph/indirect-update/C.hs new file mode 100644 index 0000000..5831959 --- /dev/null +++ b/test/data/home-module-graph/indirect-update/C.hs @@ -0,0 +1 @@ +module C where diff --git a/test/data/home-module-graph/indirect/A.hs b/test/data/home-module-graph/indirect/A.hs new file mode 100644 index 0000000..e4f573e --- /dev/null +++ b/test/data/home-module-graph/indirect/A.hs @@ -0,0 +1,4 @@ +module A where +import A1 +import A2 +import A3 diff --git a/test/data/home-module-graph/indirect/A1.hs b/test/data/home-module-graph/indirect/A1.hs new file mode 100644 index 0000000..3b7e310 --- /dev/null +++ b/test/data/home-module-graph/indirect/A1.hs @@ -0,0 +1,2 @@ +module A1 where +import B diff --git a/test/data/home-module-graph/indirect/A2.hs b/test/data/home-module-graph/indirect/A2.hs new file mode 100644 index 0000000..8e768fb --- /dev/null +++ b/test/data/home-module-graph/indirect/A2.hs @@ -0,0 +1,2 @@ +module A2 where +import C diff --git a/test/data/home-module-graph/indirect/A3.hs b/test/data/home-module-graph/indirect/A3.hs new file mode 100644 index 0000000..616ba75 --- /dev/null +++ b/test/data/home-module-graph/indirect/A3.hs @@ -0,0 +1,2 @@ +module A3 where +import B diff --git a/test/data/home-module-graph/indirect/B.hs b/test/data/home-module-graph/indirect/B.hs new file mode 100644 index 0000000..c759bc2 --- /dev/null +++ b/test/data/home-module-graph/indirect/B.hs @@ -0,0 +1 @@ +module B where diff --git a/test/data/home-module-graph/indirect/C.hs b/test/data/home-module-graph/indirect/C.hs new file mode 100644 index 0000000..5831959 --- /dev/null +++ b/test/data/home-module-graph/indirect/C.hs @@ -0,0 +1 @@ +module C where diff --git a/test/data/import-cycle/Mutual1.hs b/test/data/import-cycle/Mutual1.hs new file mode 100644 index 0000000..1b73625 --- /dev/null +++ b/test/data/import-cycle/Mutual1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted + +module Mutual1 where + +import Mutual2 diff --git a/test/data/import-cycle/Mutual2.hs b/test/data/import-cycle/Mutual2.hs new file mode 100644 index 0000000..fb5f593 --- /dev/null +++ b/test/data/import-cycle/Mutual2.hs @@ -0,0 +1,3 @@ +module Mutual2 where + +import Mutual1 diff --git a/test/data/non-exported/Fib.hs b/test/data/non-exported/Fib.hs new file mode 100644 index 0000000..f8d97f9 --- /dev/null +++ b/test/data/non-exported/Fib.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted + +module Fib () where + +fib :: Int -> Int +fib 0 = 0 +fib 1 = 1 +fib n = fib (n - 1) + fib (n - 2) diff --git a/test/data/quasi-quotes/FooQ.hs b/test/data/quasi-quotes/FooQ.hs new file mode 100644 index 0000000..223afa2 --- /dev/null +++ b/test/data/quasi-quotes/FooQ.hs @@ -0,0 +1,6 @@ +module FooQ (fooQ) where +import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter(..)) + +fooQ :: QuasiQuoter +fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined diff --git a/test/data/quasi-quotes/QuasiQuotes.hs b/test/data/quasi-quotes/QuasiQuotes.hs new file mode 100644 index 0000000..3ec7d09 --- /dev/null +++ b/test/data/quasi-quotes/QuasiQuotes.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module QuasiQuotes where + +import FooQ + +bar = [fooQ| foo bar baz |] diff --git a/test/data/template-haskell/Bar.hs b/test/data/template-haskell/Bar.hs new file mode 100644 index 0000000..d38aaaf --- /dev/null +++ b/test/data/template-haskell/Bar.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module Bar (bar) where +import Foo (foo) + +bar = $foo ++ "bar" diff --git a/test/data/template-haskell/Foo.hs b/test/data/template-haskell/Foo.hs new file mode 100644 index 0000000..3b1bb2f --- /dev/null +++ b/test/data/template-haskell/Foo.hs @@ -0,0 +1,9 @@ +module Foo (foo, fooQ) where +import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter(..)) + +foo :: ExpQ +foo = stringE "foo" + +fooQ :: QuasiQuoter +fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined diff --git a/test/data/template-haskell/ImportsTH.hs b/test/data/template-haskell/ImportsTH.hs new file mode 100644 index 0000000..0fd5838 --- /dev/null +++ b/test/data/template-haskell/ImportsTH.hs @@ -0,0 +1,3 @@ +import Bar (bar) + +main = putStrLn bar diff --git a/test/doctests.hs b/test/doctests.hs index d46e6ab..0337cc9 100644 --- a/test/doctests.hs +++ b/test/doctests.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE CPP #-} module Main where import Test.DocTest main :: IO () -main = doctest [ - "-package" - , "ghc" +main = doctest + [ "-package", "ghc" + , "-package", "transformers-" ++ VERSION_transformers + , "-package", "directory-" ++ VERSION_directory , "-XConstraintKinds", "-XFlexibleContexts", "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns" , "-idist/build/autogen/" , "-optP-include" From bee3ec35ec95c272c201b8df931569b5f507e9cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 5 Mar 2015 16:51:38 +0100 Subject: [PATCH 023/207] exe:ghc-mod: some output formatting changes --- src/GHCMod.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index af8b356..5ce05d4 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -73,7 +73,7 @@ usage = -- TODO: Generate the stuff below automatically ghcModUsage :: String ghcModUsage = - "Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\ + "Usage: ghc-mod [OPTIONS...] COMMAND [CMD_ARGS...] \n\ \*Global Options (OPTIONS)*\n\ \ Global options can be specified before and after the command and\n\ \ interspersed with command specific options\n\ @@ -383,7 +383,8 @@ progMain (globalOptions,cmdArgs) = do (res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs case res of Right s -> putStr s - Left e -> exitError $ render (gmeDoc e) + Left e -> exitError $ + renderStyle style { ribbonsPerLine = 1.2 } (gmeDoc e) -- Obtain ghc options by letting ourselfs be executed by -- @cabal repl@ @@ -524,7 +525,7 @@ newtype InvalidCommandLine = InvalidCommandLine (Either String String) instance Exception InvalidCommandLine exitError :: String -> IO a -exitError msg = hPutStrLn stderr msg >> exitFailure +exitError msg = hPutStrLn stderr (dropWhileEnd (=='\n') msg) >> exitFailure fatalError :: String -> a fatalError s = throw $ FatalError $ progName ++ ": " ++ s From 070bf54323485a3e3c8ee6aec4dfc8332b72f85b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 5 Mar 2015 16:52:11 +0100 Subject: [PATCH 024/207] Update README --- README.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/README.md b/README.md index 54e474d..713c935 100644 --- a/README.md +++ b/README.md @@ -48,3 +48,6 @@ all sorts of nasty conflicts. If you have any problems, suggestions, comments swing by [#ghc-mod](irc://chat.freenode.net/ghc-mod) on Freenode. + +Do hang around for a while if no one answers and repeat your question if you +still haven't gotten any answer after a day or so. From 8c3acd73df473af86a0aaf90983dadda4ecd3296 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 5 Mar 2015 16:52:18 +0100 Subject: [PATCH 025/207] Update .gitignore --- .gitignore | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitignore b/.gitignore index 61ecc03..1558560 100644 --- a/.gitignore +++ b/.gitignore @@ -7,6 +7,10 @@ package.cache cabal.sandbox.config # Mac OS generates # .DS_Store +*.o +*.dyn_o +*.hi +*.dyn_hi # Where do these files come from? They're not readable. # For instance, .#Help.page From 7ffded8b88aa2f8f46d4c931d6b996953ceb6c07 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 5 Mar 2015 16:56:28 +0100 Subject: [PATCH 026/207] Add back LICENSE file pointing to COPYING.* --- LICENSE | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 LICENSE diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..c646aeb --- /dev/null +++ b/LICENSE @@ -0,0 +1,6 @@ +ghc-mod was originally licensed under the BSD3 but the primary license has been +changed to the AGPL3, files originally contributed under the BSD3 license remain +under this license and can generally be identified by the lack of a GPL header. + +See the files COPYING.BSD3 and COPYING.AGPL3 in the source distribution for +copies of the two licenses. From e0bd4c6984f42a503ee8f4d7f4952e5c813c33b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 5 Mar 2015 17:25:37 +0100 Subject: [PATCH 027/207] Update ghc-mod.cabal maintainer field --- ghc-mod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 065e7ea..2d7221e 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -3,7 +3,7 @@ Version: 0 Author: Kazu Yamamoto Daniel Gröber Alejandro Serrano -Maintainer: Kazu Yamamoto +Maintainer: Daniel Gröber License: AGPL-3 License-File: LICENSE License-Files: COPYING.BSD3 COPYING.AGPL3 From eb5d0fc8677a2a6fffe02855c1c0e2ea69342622 Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Wed, 7 Jan 2015 15:51:10 +0900 Subject: [PATCH 028/207] Re-add output line separator global option for expand command. --- elisp/ghc-info.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el index acfbb05..eed8bd5 100644 --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -127,7 +127,7 @@ (defun ghc-expand-th () (interactive) (let* ((file (buffer-file-name)) - (cmds (list "expand" file)) + (cmds (list "-b" "\n" "expand" file)) (source (ghc-run-ghc-mod cmds))) (when source (ghc-display From 2151363dd628b3dad739a1f899dc3becbae5fa41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 5 Mar 2015 18:54:39 +0100 Subject: [PATCH 029/207] Add back `-d` option to `modules` command --- Language/Haskell/GhcMod/Gap.hs | 21 +++++++++++++++++---- Language/Haskell/GhcMod/Modules.hs | 21 ++++++++++++++++----- src/GHCMod.hs | 16 ++++++++++++++-- 3 files changed, 47 insertions(+), 11 deletions(-) diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index eab83d0..f76c7ce 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -38,6 +38,7 @@ module Language.Haskell.GhcMod.Gap ( , occName , listVisibleModuleNames , listVisibleModules + , lookupModulePackageInAllPackages , Language.Haskell.GhcMod.Gap.isSynTyCon , parseModuleHeader ) where @@ -89,20 +90,18 @@ import RdrName (rdrNameOcc) #if __GLASGOW_HASKELL__ < 710 import UniqFM (eltsUFM) -import Packages (exposedModules, exposed, pkgIdMap) -import PackageConfig (PackageConfig, packageConfigId) +import Module #endif #if __GLASGOW_HASKELL__ >= 704 import qualified Data.IntSet as I (IntSet, empty) #endif - import Bag import Lexer as L import Parser import SrcLoc - +import Packages ---------------------------------------------------------------- ---------------------------------------------------------------- @@ -476,6 +475,20 @@ listVisibleModuleNames :: DynFlags -> [ModuleName] listVisibleModuleNames = allExposedModules #endif +lookupModulePackageInAllPackages :: + DynFlags -> ModuleName -> [String] +lookupModulePackageInAllPackages df mn = +#if __GLASGOW_HASKELL__ >= 710 + unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn + where + unpackSPId (SourcePackageId fs) = unpackFS fs +#else + unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn + where + unpackPId pid = packageIdString $ mkPackageId pid +-- n ++ "-" ++ showVersion v +#endif + listVisibleModules :: DynFlags -> [GHC.Module] listVisibleModules df = let #if __GLASGOW_HASKELL__ >= 710 diff --git a/Language/Haskell/GhcMod/Modules.hs b/Language/Haskell/GhcMod/Modules.hs index 3a2c024..d489138 100644 --- a/Language/Haskell/GhcMod/Modules.hs +++ b/Language/Haskell/GhcMod/Modules.hs @@ -1,15 +1,26 @@ module Language.Haskell.GhcMod.Modules (modules) where -import qualified GHC as G +import Control.Arrow +import Data.List import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Gap (listVisibleModuleNames) -import Module (moduleNameString) +import Language.Haskell.GhcMod.Gap ( listVisibleModuleNames + , lookupModulePackageInAllPackages + ) + +import qualified GHC as G ---------------------------------------------------------------- -- | Listing installed modules. modules :: (IOish m, GmEnv m) => m String modules = do - dflags <- runGmPkgGhc G.getSessionDynFlags - convert' $ map moduleNameString $ listVisibleModuleNames dflags + Options { detailed } <- options + df <- runGmPkgGhc G.getSessionDynFlags + let mns = listVisibleModuleNames df + pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns) + convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn + | (mn, pkgs) <- pmnss, pkg <- pkgs ] + where + modulePkg df = lookupModulePackageInAllPackages df diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 5ce05d4..3aa5108 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -88,6 +88,9 @@ ghcModUsage = \\n\ \ - list [FLAGS...] | modules [FLAGS...]\n\ \ List all visible modules.\n\ + \ Flags:\n\ + \ -d\n\ + \ Print package modules belong to.\n\ \\n\ \ - lang\n\ \ List all known GHC language extensions.\n\ @@ -558,7 +561,8 @@ modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd :: IOish m => [String] -> GhcModT m String -modulesCmd = withParseCmd' "modules" [] $ \[] -> modules +modulesCmd = withParseCmd' "modules" s $ \[] -> modules + where s = modulesArgSpec languagesCmd = withParseCmd' "lang" [] $ \[] -> languages flagsCmd = withParseCmd' "flag" [] $ \[] -> flags debugInfoCmd = withParseCmd' "debug" [] $ \[] -> debugInfo @@ -571,7 +575,7 @@ findSymbolCmd = withParseCmd' "find" [] $ \[sym] -> findSymbol sym pkgDocCmd = withParseCmd' "doc" [] $ \[mdl] -> pkgDoc mdl lintCmd = withParseCmd' "lint" s $ \[file] -> lint file where s = hlintArgSpec -browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls +browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls where s = browseArgSpec checkSyntaxCmd = withParseCmd [] $ checkAction checkSyntax expandTemplateCmd = withParseCmd [] $ checkAction expandTemplate @@ -601,6 +605,14 @@ locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) expr locAction' _ action [f, line,col,expr] = action f (read line) (read col) expr locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd) + +modulesArgSpec :: [OptDescr (Options -> Options)] +modulesArgSpec = + [ option "d" ["detailed"] "Print package modules belong to." $ + NoArg $ \o -> o { detailed = True } + ] + + hlintArgSpec :: [OptDescr (Options -> Options)] hlintArgSpec = [ option "h" ["hlintOpt"] "Option to be passed to hlint" $ From ca35e99254c80c92a6d9419818ebce531d815370 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 5 Mar 2015 19:47:40 +0100 Subject: [PATCH 030/207] Remove Cabal version sanity check from Setup.hs --- Setup.hs | 93 ++++++++++++++++++++++++++++---------------------------- 1 file changed, 46 insertions(+), 47 deletions(-) diff --git a/Setup.hs b/Setup.hs index 20e34b2..b44e529 100755 --- a/Setup.hs +++ b/Setup.hs @@ -31,7 +31,7 @@ main = defaultMainWithHooks $ simpleUserHooks { , instHook = \pd lbi uh ifl -> (instHook simpleUserHooks) pd lbi uh ifl - , postConf = sanityCheckCabalVersions +-- , postConf = sanityCheckCabalVersions } xBuildDependsLike :: LocalBuildInfo -> LocalBuildInfo @@ -118,59 +118,58 @@ parseVer str = [(ver, _)] -> ver _ -> error $ "No parse (Ver) :(\n" ++ str ++ "\n" -sanityCheckCabalVersions args cf desc lbi = do - (cabalInstallVer, cabalVer) <- getCabalExecVer +-- sanityCheckCabalVersions args cf desc lbi = do +-- (cabalInstallVer, cabalVer) <- getCabalExecVer - let - ghcVer = compilerVersion (compiler lbi) - -- ghc >= 7.10? - minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10") +-- let +-- ghcVer = compilerVersion (compiler lbi) +-- -- ghc >= 7.10? +-- minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10") - when minGhc710 $ do - let cabalHelperCabalVer = compCabalVer (CExeName "cabal-helper") +-- when minGhc710 $ do +-- let cabalHelperCabalVer = compCabalVer (CExeName "cabal-helper") - when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $ - failCabalVersionDifferent cabalVer cabalHelperCabalVer +-- when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $ +-- failCabalVersionDifferent cabalVer cabalHelperCabalVer - -- carry on as usual - (postConf simpleUserHooks) args cf desc lbi +-- -- carry on as usual +-- (postConf simpleUserHooks) args cf desc lbi - where - earlierVersionThan ver ver' = - ver `withinRange` earlierVersion ver' - sameMajorVersionAs ver ver' = - ver `withinRange` withinVersion (Version (take 2 $ versionBranch ver') []) +-- where +-- earlierVersionThan ver ver' = +-- ver `withinRange` earlierVersion ver' +-- sameMajorVersionAs ver ver' = +-- ver `withinRange` withinVersion (Version (take 2 $ versionBranch ver') []) - compCabalVer comp = let - clbi = getComponentLocalBuildInfo lbi comp +-- compCabalVer comp = let +-- clbi = getComponentLocalBuildInfo lbi comp - [cabalVer] = - [ ver | (_, PackageIdentifier pkg ver) <- componentPackageDeps clbi - , pkg == PackageName "Cabal" ] - in cabalVer +-- [cabalVer] = +-- [ ver | (_, PackageIdentifier pkg ver) <- componentPackageDeps clbi +-- , pkg == PackageName "Cabal" ] +-- in cabalVer +-- getCabalExecVer = do +-- ["cabal-install", "version", cabalInstallVer, "using", "version", cabalVer, "of", "the", "Cabal", "library"] <- words <$> readProcess "cabal" ["--version"] "" +-- return (parseVer cabalInstallVer, parseVer cabalVer) -getCabalExecVer = do - ["cabal-install", "version", cabalInstallVer, "using", "version", cabalVer, "of", "the", "Cabal", "library"] <- words <$> readProcess "cabal" ["--version"] "" - return (parseVer cabalInstallVer, parseVer cabalVer) +-- failCabalVersionDifferent cabalVer libCabalVer = +-- putStrLn rerr >> exitFailure +-- where +-- replace :: String -> String -> String -> String +-- replace _ _ [] = [] +-- replace n r h@(h':hs) +-- | map snd (n `zip` h ) == n = r ++ replace n r (drop (length n) h) +-- | otherwise = h':replace n r hs -failCabalVersionDifferent cabalVer libCabalVer = - putStrLn rerr >> exitFailure - where - replace :: String -> String -> String -> String - replace _ _ [] = [] - replace n r h@(h':hs) - | map snd (n `zip` h ) == n = r ++ replace n r (drop (length n) h) - | otherwise = h':replace n r hs - - rerr = replace "X.XX.X.X" (showVersion libCabalVer) $ - replace "Y.YY.Y.Y" (showVersion cabalVer) err - err = "\ -\Error: Cabal seems to have decided ghc-mod should be built using Cabal\n\ -\X.XX.X.X while the `cabal' executable in your PATH was built with Cabal\n\ -\Y.YY.Y.Y. This will lead to conflicts when running ghc-mod in any project\n\ -\where you use this `cabal' executable. Please compile ghc-mod using the same\n\ -\Cabal version as your `cabal' executable or recompile cabal-install using\n\ -\this version of the Cabal library.\n\ -\\n\ -\See: https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions\n" +-- rerr = replace "X.XX.X.X" (showVersion libCabalVer) $ +-- replace "Y.YY.Y.Y" (showVersion cabalVer) err +-- err = "\ +-- \Error: Cabal seems to have decided ghc-mod should be built using Cabal\n\ +-- \X.XX.X.X while the `cabal' executable in your PATH was built with Cabal\n\ +-- \Y.YY.Y.Y. This will lead to conflicts when running ghc-mod in any project\n\ +-- \where you use this `cabal' executable. Please compile ghc-mod using the same\n\ +-- \Cabal version as your `cabal' executable or recompile cabal-install using\n\ +-- \this version of the Cabal library.\n\ +-- \\n\ +-- \See: https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions\n" From 1bc9706fe6e5eb11eab52b911afad3216479535e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 6 Mar 2015 12:08:06 +0100 Subject: [PATCH 031/207] cabal-helper: don't install Cabal into the user prefix --- CabalHelper/Wrapper.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs index 25f698c..68601a9 100644 --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -265,6 +265,7 @@ installCabal ver = do callProcessStderr (Just "/") "cabal" [ "--package-db=clear" , "--package-db=global" , "--package-db=" ++ db + , "--prefix=" ++ db "prefix" , "-j1" , "install", "Cabal-"++showVersion ver ] From 9d5ee06af81ddd5531b1b185b37a1bc8ff33f729 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 6 Mar 2015 14:04:16 +0100 Subject: [PATCH 032/207] Fix GHC 7.10-rc1 --- CabalHelper/Main.hs | 4 ++++ .../pattern-synonyms/pattern-synonyms.cabal | 20 +++++++++---------- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs index 8838f4d..1d22abb 100644 --- a/CabalHelper/Main.hs +++ b/CabalHelper/Main.hs @@ -58,6 +58,10 @@ import qualified Distribution.ModuleName as C (ModuleName) import Distribution.Text (display) import Distribution.Verbosity (Verbosity, silent, deafening) +#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22 +import Distribution.Utils.NubList +#endif + import Control.Applicative ((<$>)) import Control.Monad import Control.Exception (catch, PatternMatchFail(..)) diff --git a/test/data/pattern-synonyms/pattern-synonyms.cabal b/test/data/pattern-synonyms/pattern-synonyms.cabal index a9b0489..06cf5fd 100644 --- a/test/data/pattern-synonyms/pattern-synonyms.cabal +++ b/test/data/pattern-synonyms/pattern-synonyms.cabal @@ -1,24 +1,24 @@ --- Initial pattern-synonyms.cabal generated by cabal init. For further +-- Initial pattern-synonyms.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: pattern-synonyms version: 0.1.0.0 --- synopsis: --- description: --- license: +-- synopsis: +-- description: +-- license: license-file: LICENSE author: Daniel Gröber maintainer: dxld@darkboxed.org --- copyright: --- category: +-- copyright: +-- category: build-type: Simple --- extra-source-files: +-- extra-source-files: cabal-version: >=1.10 library exposed-modules: A, B - -- other-modules: + -- other-modules: other-extensions: PatternSynonyms - build-depends: base >=4.7 && <4.8 - -- hs-source-dirs: + build-depends: base + -- hs-source-dirs: default-language: Haskell2010 \ No newline at end of file From b3b4b91ff8ccce43d6d8b722c7b2e9eb58973e0b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 6 Mar 2015 14:04:31 +0100 Subject: [PATCH 033/207] Fix sloppy recompilation checking in cabal-helper-wrapper --- CabalHelper/Wrapper.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs index 68601a9..880b28f 100644 --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -203,9 +203,13 @@ compile Compile {..} = do recompile <- case cabalSourceDir of Nothing -> do - tsrcs <- timeHsFiles cabalHelperSourceDir - texe <- timeMaybe exe - return $ any ((texe <) . Just) tsrcs + exists <- doesFileExist exe + case exists of + False -> return True + True -> do + tsrcs <- timeHsFiles cabalHelperSourceDir + texe <- timeFile exe + return $ any (texe <) tsrcs Just _ -> return True -- let ghc do the difficult recomp checking let Version (mj:mi:_) _ = cabalVersion From c8da5b80854e9dc855e39e78524660d7a31a8c9e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 6 Mar 2015 14:04:49 +0100 Subject: [PATCH 034/207] Fix line endings in logging output --- Language/Haskell/GhcMod/Logging.hs | 5 ++++- test/TestUtils.hs | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 9c7ebe9..9a089b1 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -23,6 +23,8 @@ module Language.Haskell.GhcMod.Logging ( ) where import Control.Monad +import Data.List +import Data.Char import Data.Monoid (mempty, mappend, mconcat, (<>)) import System.IO import Text.PrettyPrint hiding (style, (<>)) @@ -52,7 +54,8 @@ gmLog level loc' doc = do let loc | loc' == "" = empty | otherwise = text (head $ lines loc') <> colon msg = gmRenderDoc $ gmLogLevelDoc level <+> loc <+> doc + msg' = dropWhileEnd isSpace msg when (Just level <= level') $ - liftIO $ hPutStr stderr msg + liftIO $ hPutStrLn stderr msg' gmlJournal (GhcModLog Nothing [(level, render loc, msg)]) diff --git a/test/TestUtils.hs b/test/TestUtils.hs index d2c8132..1f52a1d 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -31,7 +31,7 @@ import Test.Hspec import Exception testLogLevel :: GmLogLevel -testLogLevel = GmException +testLogLevel = GmDebug extract :: Show e => IO (Either e a, w) -> IO a extract action = do From 8aece596383cc7f58178c869ad3fb6b5ecd57e86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 6 Mar 2015 14:39:54 +0100 Subject: [PATCH 035/207] Add other-modules to library entrypoints --- CabalHelper/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs index 1d22abb..ee1ae38 100644 --- a/CabalHelper/Main.hs +++ b/CabalHelper/Main.hs @@ -282,7 +282,7 @@ gmModuleName = GmModuleName . intercalate "." . components componentEntrypoints :: Component -> Either FilePath [GmModuleName] componentEntrypoints (CLib Library {..}) - = Right $ map gmModuleName exposedModules + = Right $ map gmModuleName $ exposedModules ++ (otherModules libBuildInfo) componentEntrypoints (CExe Executable {..}) = Left modulePath componentEntrypoints (CTest TestSuite { testInterface = TestSuiteExeV10 _ fp }) From b9230c7e3fd8d3335d30b6718252df6f3b87d731 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 6 Mar 2015 14:49:12 +0100 Subject: [PATCH 036/207] Another recomp bug fixed --- CabalHelper/Wrapper.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs index 880b28f..13f374c 100644 --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -207,7 +207,7 @@ compile Compile {..} = do case exists of False -> return True True -> do - tsrcs <- timeHsFiles cabalHelperSourceDir + tsrcs <- timeHsFiles $ cabalHelperSourceDir "CabalHelper" texe <- timeFile exe return $ any (texe <) tsrcs Just _ -> return True -- let ghc do the difficult recomp checking From c05bd816e77e6f74b015516af7ade69e8652d6e5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 6 Mar 2015 19:46:56 +0100 Subject: [PATCH 037/207] Add quiet option to decrease log level --- Language/Haskell/GhcMod.hs | 1 + Language/Haskell/GhcMod/Logging.hs | 4 ++++ src/GHCMod.hs | 7 ++++++- 3 files changed, 11 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index b9a1976..68d26f9 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -12,6 +12,7 @@ module Language.Haskell.GhcMod ( -- * Logging , GmLogLevel , increaseLogLevel + , decreaseLogLevel , gmSetLogLevel , gmLog -- * Types diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 9a089b1..26a7205 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -40,6 +40,10 @@ increaseLogLevel :: GmLogLevel -> GmLogLevel increaseLogLevel l | l == maxBound = l increaseLogLevel l = succ l +decreaseLogLevel :: GmLogLevel -> GmLogLevel +decreaseLogLevel l | l == minBound = l +decreaseLogLevel l = succ l + -- | -- >>> Just GmDebug <= Nothing -- False diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 3aa5108..b086a9a 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -263,9 +263,14 @@ reqArg udsc dsc = ReqArg dsc udsc globalArgSpec :: [OptDescr (Options -> Options)] globalArgSpec = [ option "v" ["verbose"] "Can be given multiple times to be increasingly\ - \more verbose." $ + \ be more verbose." $ NoArg $ \o -> o { logLevel = increaseLogLevel (logLevel o) } + , option "q" [] "Can be given multiple times to be increasingly be less\ + \ verbose." $ + NoArg $ \o -> o { logLevel = decreaseLogLevel (logLevel o) } + + , option "l" ["tolisp"] "Format output as an S-Expression" $ NoArg $ \o -> o { outputStyle = LispStyle } From e23772b1ed4dba2826f25a7e7cd7d2b1acc0b2e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 6 Mar 2015 15:48:26 +0100 Subject: [PATCH 038/207] Recache cabal-helper stuff when cabal-helper-* executable changes --- CabalHelper/Wrapper.hs | 42 ++++++++++++++---------- Language/Haskell/GhcMod/CabalHelper.hs | 9 +++-- Language/Haskell/GhcMod/PathsAndFiles.hs | 7 ++-- 3 files changed, 32 insertions(+), 26 deletions(-) diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs index 13f374c..072828c 100644 --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -54,16 +54,17 @@ usage = do usageMsg = "\ \( print-appdatadir\n\ \| print-build-platform\n\ -\| DIST_DIR [CABAL_HELPER_ARGS...]\n\ -\)\n" +\| DIST_DIR ( print-exe | [CABAL_HELPER_ARGS...] ) )\n" main :: IO () main = handlePanic $ do args <- getArgs case args of + [] -> usage + "--help":[] -> usage "print-appdatadir":[] -> putStrLn =<< appDataDir "print-build-platform":[] -> putStrLn $ display buildPlatform - distdir:_ -> do + distdir:args' -> do cfgf <- canonicalizePath (distdir "setup-config") mhdr <- getCabalConfigHeader cfgf case mhdr of @@ -76,11 +77,12 @@ main = handlePanic $ do eexe <- compileHelper hdrCabalVersion case eexe of Left e -> exitWith e - Right exe -> do - (_,_,_,h) <- createProcess $ proc exe args - exitWith =<< waitForProcess h - - _ -> usage + Right exe -> + case args' of + "print-exe":_ -> putStrLn exe + _ -> do + (_,_,_,h) <- createProcess $ proc exe args + exitWith =<< waitForProcess h appDataDir :: IO FilePath appDataDir = ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" @@ -137,7 +139,7 @@ compileHelper cabalVer = do db <- installCabal cabalVer `E.catch` \(SomeException _) -> errorInstallCabal cabalVer compileWithPkg chdir (Just db) - Just _ -> + Just _ -> do compileWithPkg chdir Nothing where @@ -229,12 +231,25 @@ compile Compile {..} = do if recompile then do + -- TODO: touch exe after, ghc doesn't do that if the input files didn't + -- actually change rv <- callProcessStderr' Nothing "ghc" ghc_opts return $ case rv of ExitSuccess -> Right exe e@(ExitFailure _) -> Left e else return $ Right exe + where + timeHsFiles :: FilePath -> IO [TimedFile] + timeHsFiles dir = do + fs <- map (dir) <$> getDirectoryContents dir + mapM timeFile =<< filterM isHsFile (filter (=="Wrapper.hs") fs) + where + isHsFile f = do + exists <- doesFileExist f + return $ exists && ".hs" `isSuffixOf` f + + callProcessStderr' :: Maybe FilePath -> FilePath -> [String] -> IO ExitCode callProcessStderr' mwd exe args = do (_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr @@ -254,15 +269,6 @@ processFailedException fn exe args rv = , intercalate " " (map show args) , " (exit " ++ show rv ++ ")"] -timeHsFiles :: FilePath -> IO [TimedFile] -timeHsFiles dir = do - fs <- map (dir) <$> getDirectoryContents dir - mapM timeFile =<< filterM isHsFile fs - where - isHsFile f = do - exists <- doesFileExist f - return $ exists && ".hs" `isSuffixOf` f - installCabal :: Version -> IO FilePath installCabal ver = do db <- createPkgDb ver diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 0f83443..5b5661e 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -80,18 +80,17 @@ data CabalHelper = CabalHelper { cabalHelper :: (MonadIO m, GmEnv m) => m CabalHelper cabalHelper = withCabal $ do + Cradle {..} <- cradle let cmds = [ "entrypoints" , "source-dirs" , "ghc-options" , "ghc-src-options" , "ghc-pkg-options" ] + distdir = cradleRootDir "dist" - Cradle {..} <- cradle exe <- liftIO $ findLibexecExe "cabal-helper-wrapper" - - let distdir = cradleRootDir "dist" - - res <- liftIO $ cached cradleRootDir (cabalHelperCache cmds) $ do + hexe <- liftIO $ readProcess exe [distdir, "print-exe"] "" + res <- liftIO $ cached cradleRootDir (cabalHelperCache hexe cmds) $ do out <- readProcess exe (distdir:cmds) "" evaluate (read out) `E.catch` \(SomeException _) -> error "cabalHelper: read failed" diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index d0b925d..efbb98f 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -233,9 +233,10 @@ cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $ packageCache :: String packageCache = "package.cache" -cabalHelperCache :: [String] -> Cached [String] [Maybe GmCabalHelperResponse] -cabalHelperCache cmds = Cached { - inputFiles = [setupConfigPath], +cabalHelperCache :: + FilePath -> [String] -> Cached [String] [Maybe GmCabalHelperResponse] +cabalHelperCache cabalHelperExe cmds = Cached { + inputFiles = [cabalHelperExe, setupConfigPath], inputData = cmds, cacheFile = setupConfigPath <.> "ghc-mod.cabal-helper" } From 85d4844a0d62a8c79af2091da06785bdc5b035f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 6 Mar 2015 19:49:26 +0100 Subject: [PATCH 039/207] Improve suggestions on inconsistent assignment --- Language/Haskell/GhcMod/Error.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 4675b13..cefdc0e 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -102,13 +102,18 @@ gmeDoc e = case e of text "Could not find a consistent component assignment for modules:" $$ (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$ text "" $$ - text "- Are you sure all these modules exist?" $$ - text "- Maybe try enabling test suites and or benchmarks:" $$ - nest 4 (backticks $ text "cabal configure --enable-tests --enable-benchmarks") $$ + (if all (Set.null . snd) ctx + then noComponentSuggestions + else empty) $$ text "- To find out which components ghc-mod knows about try:" $$ nest 4 (backticks $ text "ghc-mod debug") where + noComponentSuggestions = + text "- Are some of these modules part of a test and or benchmark?\ + \ Try enabling them:" $$ + nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]") + backticks d = char '`' <> d <> char '`' ctxDoc = moduleDoc *** compsDoc >>> first (<> colon) >>> uncurry (flip hang 4) From baf5cad8092d8c56cc1dd4fb382a1153cc190c2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 7 Mar 2015 19:23:55 +0100 Subject: [PATCH 040/207] Pass through --with-* options to cabal-helper --- CabalHelper/Common.hs | 4 +- CabalHelper/GuessGhc.hs | 83 +++++++ CabalHelper/Wrapper.hs | 290 ++++++++++++++++--------- Language/Haskell/GhcMod/CabalHelper.hs | 40 ++-- Language/Haskell/GhcMod/Types.hs | 11 +- src/GHCMod.hs | 7 +- 6 files changed, 316 insertions(+), 119 deletions(-) create mode 100644 CabalHelper/GuessGhc.hs diff --git a/CabalHelper/Common.hs b/CabalHelper/Common.hs index 7c2a2ac..884c486 100644 --- a/CabalHelper/Common.hs +++ b/CabalHelper/Common.hs @@ -93,4 +93,6 @@ parseVer vers = runReadP parseVersion vers -- sameMajorVersion a b = majorVer a == majorVer b runReadP :: ReadP t -> String -> t -runReadP p i = let (a,""):[] = filter ((=="") . snd) $ readP_to_S p i in a +runReadP p i = case filter ((=="") . snd) $ readP_to_S p i of + (a,""):[] -> a + _ -> error $ "Error parsing: " ++ show i diff --git a/CabalHelper/GuessGhc.hs b/CabalHelper/GuessGhc.hs new file mode 100644 index 0000000..0827456 --- /dev/null +++ b/CabalHelper/GuessGhc.hs @@ -0,0 +1,83 @@ +module CabalHelper.GuessGhc (guessToolFromGhcPath) where + +import Data.Maybe +import Data.Char +import Distribution.Simple.BuildPaths +import System.Directory +import System.FilePath + +-- Copyright (c) 2003-2014, Isaac Jones, Simon Marlow, Martin Sjögren, +-- Bjorn Bringert, Krasimir Angelov, +-- Malcolm Wallace, Ross Patterson, Ian Lynagh, +-- Duncan Coutts, Thomas Schilling, +-- Johan Tibell, Mikhail Glushenkov +-- All rights reserved. + +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: + +-- * Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. + +-- * Redistributions in binary form must reproduce the above +-- copyright notice, this list of conditions and the following +-- disclaimer in the documentation and/or other materials provided +-- with the distribution. + +-- * Neither the name of Isaac Jones nor the names of other +-- contributors may be used to endorse or promote products derived +-- from this software without specific prior written permission. + +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +guessToolFromGhcPath :: FilePath -- ^ Tool name + -> FilePath -- ^ GHC exe path + -> IO (Maybe FilePath) +guessToolFromGhcPath toolname ghcPath + = do let + path = ghcPath + dir = takeDirectory path + versionSuffix = takeVersionSuffix (dropExeExtension path) + guessNormal = dir toolname <.> exeExtension + guessGhcVersioned = dir (toolname ++ "-ghc" ++ versionSuffix) + <.> exeExtension + guessVersioned = dir (toolname ++ versionSuffix) + <.> exeExtension + guesses | null versionSuffix = [guessNormal] + | otherwise = [guessGhcVersioned, + guessVersioned, + guessNormal] + exists <- mapM doesFileExist guesses + return $ listToMaybe [ file | (file, True) <- zip guesses exists ] + + where takeVersionSuffix :: FilePath -> String + takeVersionSuffix = takeWhileEndLE isSuffixChar + + isSuffixChar :: Char -> Bool + isSuffixChar c = isDigit c || c == '.' || c == '-' + + dropExeExtension :: FilePath -> FilePath + dropExeExtension filepath = + case splitExtension filepath of + (filepath', extension) | extension == exeExtension -> filepath' + | otherwise -> filepath + +-- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but +-- is usually faster (as well as being easier to read). +takeWhileEndLE :: (a -> Bool) -> [a] -> [a] +takeWhileEndLE p = fst . foldr go ([], False) + where + go x (rest, done) + | not done && p x = (x:rest, False) + | otherwise = (rest, True) diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs index 072828c..eef1fd4 100644 --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -14,7 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE TemplateHaskell, RecordWildCards #-} +{-# LANGUAGE TemplateHaskell, RecordWildCards, FlexibleContexts #-} module Main where import Control.Applicative @@ -22,12 +22,14 @@ import Control.Arrow import Control.Exception as E import Control.Monad import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class import Data.Char import Data.List import Data.Maybe import Data.String import Data.Version import Text.Printf +import System.Console.GetOpt import System.Environment import System.Directory import System.FilePath @@ -42,6 +44,7 @@ import NotCPP.Declarations import Paths_ghc_mod import CabalHelper.Common +import CabalHelper.GuessGhc import Utils ifD [d| getExecutablePath = getProgName |] @@ -56,9 +59,57 @@ usage = do \| print-build-platform\n\ \| DIST_DIR ( print-exe | [CABAL_HELPER_ARGS...] ) )\n" +data Options = Options { + ghcProgram :: FilePath + , ghcPkgProgram :: FilePath + , cabalProgram :: FilePath +} + +defaultOptions :: Options +defaultOptions = Options "ghc" "ghc-pkg" "cabal" + +globalArgSpec :: [OptDescr (Options -> Options)] +globalArgSpec = + [ option "" ["with-ghc"] "GHC executable to use" $ + reqArg "PROG" $ \p o -> o { ghcProgram = p } + + , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $ + reqArg "PROG" $ \p o -> o { ghcPkgProgram = p } + + , option "" ["with-cabal"] "cabal-install executable to use" $ + reqArg "PROG" $ \p o -> o { cabalProgram = p } + ] + where + option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a + option s l udsc dsc = Option s l dsc udsc + + reqArg :: String -> (String -> a) -> ArgDescr a + reqArg udsc dsc = ReqArg dsc udsc + +parseCommandArgs :: Options -> [String] -> (Options, [String]) +parseCommandArgs opts argv + = case getOpt Permute globalArgSpec argv of + (o,r,[]) -> (foldr id opts o, r) + (_,_,errs) -> + panic $ "Parsing command options failed: " ++ concat errs + +guessProgramPaths :: Options -> IO Options +guessProgramPaths opts = do + mghcPkg <- guessToolFromGhcPath "ghc-pkg" (ghcProgram opts) + let guessedGhcPkg = fromMaybe (ghcPkgProgram dopts) mghcPkg + return opts { + ghcPkgProgram = if guessGhcPkg then guessedGhcPkg else ghcPkgProgram dopts + } + where + guessGhcPkg = nsame ghcProgram opts dopts && same ghcPkgProgram opts dopts + same f o o' = f o == f o' + nsame f o o' = f o /= f o' + dopts = defaultOptions + main :: IO () main = handlePanic $ do - args <- getArgs + (opts', args) <- parseCommandArgs defaultOptions <$> getArgs + opts <- guessProgramPaths opts' case args of [] -> usage "--help":[] -> usage @@ -74,7 +125,7 @@ main = handlePanic $ do \- Maybe try: $ cabal configure" cfgf Just (hdrCabalVersion, _hdrCompilerVersion) -> do - eexe <- compileHelper hdrCabalVersion + eexe <- compileHelper opts hdrCabalVersion case eexe of Left e -> exitWith e Right exe -> @@ -112,42 +163,60 @@ findCabalHelperSourceDir = do Nothing -> getDataDir >>= errorNoMain Just datadir -> return datadir -compileHelper :: Version -> IO (Either ExitCode FilePath) -compileHelper cabalVer = do +compileHelper :: Options -> Version -> IO (Either ExitCode FilePath) +compileHelper opts cabalVer = do chdir <- findCabalHelperSourceDir - - -- First check if we already compiled this version of cabal - db_exists <- cabalPkgDbExists cabalVer - case db_exists of - True -> compileWithPkg chdir . Just =<< cabalPkgDb cabalVer - False -> do - -- Next check if this version is globally available - mver <- find (== cabalVer) <$> listCabalVersions - couldBeSrcDir <- takeDirectory <$> getDataDir - case mver of - Nothing -> do - -- If not see if we're in a cabal source tree - let cabalFile = couldBeSrcDir "Cabal.cabal" - cabal <- doesFileExist cabalFile - if cabal - then do - ver <- cabalFileVersion <$> readFile cabalFile - compileWithCabalTree chdir ver couldBeSrcDir - else do - -- otherwise compile the requested cabal version into an isolated - -- package-db - db <- installCabal cabalVer `E.catch` - \(SomeException _) -> errorInstallCabal cabalVer - compileWithPkg chdir (Just db) - Just _ -> do - compileWithPkg chdir Nothing + run [ Right <$> MaybeT (cachedExe cabalVer chdir) + , compileGlobal chdir + , cachedCabalPkg chdir + , compileCabalSource chdir + , MaybeT (Just <$> compileSandbox chdir) + ] where + run actions = fromJust <$> runMaybeT (msum actions) + + -- | Check if this version is globally available + compileGlobal :: FilePath -> MaybeT IO (Either ExitCode FilePath) + compileGlobal chdir = do + _ <- MaybeT $ find (== cabalVer) <$> listCabalVersions opts + liftIO $ compileWithPkg chdir Nothing + + -- | Check if we already compiled this version of cabal into a private + -- package-db + cachedCabalPkg :: FilePath -> MaybeT IO (Either ExitCode FilePath) + cachedCabalPkg chdir = do + db_exists <- liftIO $ cabalPkgDbExists opts cabalVer + case db_exists of + False -> mzero + True -> liftIO $ do + db <- cabalPkgDb opts cabalVer + compileWithPkg chdir (Just db) + + -- | See if we're in a cabal source tree + compileCabalSource :: FilePath -> MaybeT IO (Either ExitCode FilePath) + compileCabalSource chdir = do + couldBeSrcDir <- liftIO $ takeDirectory <$> getDataDir + let cabalFile = couldBeSrcDir "Cabal.cabal" + cabal <- liftIO $ doesFileExist cabalFile + case cabal of + False -> mzero + True -> liftIO $ do + ver <- cabalFileVersion <$> readFile cabalFile + compileWithCabalTree chdir ver couldBeSrcDir + + -- | Compile the requested cabal version into an isolated package-db + compileSandbox :: FilePath -> IO (Either ExitCode FilePath) + compileSandbox chdir = do + db <- installCabal opts cabalVer `E.catch` + \(SomeException _) -> errorInstallCabal cabalVer + compileWithPkg chdir (Just db) + compileWithCabalTree chdir ver srcDir = - compile $ Compile chdir (Just srcDir) Nothing ver [] + compile opts $ Compile chdir (Just srcDir) Nothing ver [] compileWithPkg chdir mdb = - compile $ Compile chdir Nothing mdb cabalVer [cabalPkgId cabalVer] + compile opts $ Compile chdir Nothing mdb cabalVer [cabalPkgId cabalVer] cabalPkgId v = "Cabal-" ++ showVersion v @@ -195,24 +264,11 @@ data Compile = Compile { packageDeps :: [String] } -compile :: Compile -> IO (Either ExitCode FilePath) -compile Compile {..} = do +compile :: Options -> Compile -> IO (Either ExitCode FilePath) +compile Options {..} Compile {..} = do outdir <- appDataDir createDirectoryIfMissing True outdir - - let exe = outdir "cabal-helper-" ++ showVersion cabalVersion - - recompile <- - case cabalSourceDir of - Nothing -> do - exists <- doesFileExist exe - case exists of - False -> return True - True -> do - tsrcs <- timeHsFiles $ cabalHelperSourceDir "CabalHelper" - texe <- timeFile exe - return $ any (texe <) tsrcs - Just _ -> return True -- let ghc do the difficult recomp checking + exe <- exePath cabalVersion let Version (mj:mi:_) _ = cabalVersion let ghc_opts = @@ -229,26 +285,31 @@ compile Compile {..} = do [ "--make", cabalHelperSourceDir "CabalHelper/Main.hs" ] ] - if recompile - then do - -- TODO: touch exe after, ghc doesn't do that if the input files didn't - -- actually change - rv <- callProcessStderr' Nothing "ghc" ghc_opts - return $ case rv of - ExitSuccess -> Right exe - e@(ExitFailure _) -> Left e - else return $ Right exe + -- TODO: touch exe after, ghc doesn't do that if the input files didn't + -- actually change + rv <- callProcessStderr' Nothing ghcProgram ghc_opts + return $ case rv of + ExitSuccess -> Right exe + e@(ExitFailure _) -> Left e +exePath :: Version -> IO FilePath +exePath cabalVersion = do + outdir <- appDataDir + return $ outdir "cabal-helper-" ++ showVersion cabalVersion + +cachedExe :: Version -> FilePath -> IO (Maybe FilePath) +cachedExe cabalVersion chdir = do + exe <- exePath cabalVersion + exists <- doesFileExist exe + case exists of + False -> return Nothing + True -> do + texe <- timeFile exe + tsrcs <- mapM timeFile srcFiles + return $ if any (texe <) tsrcs then Nothing else Just exe where - timeHsFiles :: FilePath -> IO [TimedFile] - timeHsFiles dir = do - fs <- map (dir) <$> getDirectoryContents dir - mapM timeFile =<< filterM isHsFile (filter (=="Wrapper.hs") fs) - where - isHsFile f = do - exists <- doesFileExist f - return $ exists && ".hs" `isSuffixOf` f - + srcFiles = + map ((chdir "CabalHelper") ) ["Main.hs", "Common.hs", "Types.hs"] callProcessStderr' :: Maybe FilePath -> FilePath -> [String] -> IO ExitCode callProcessStderr' mwd exe args = do @@ -269,51 +330,84 @@ processFailedException fn exe args rv = , intercalate " " (map show args) , " (exit " ++ show rv ++ ")"] -installCabal :: Version -> IO FilePath -installCabal ver = do - db <- createPkgDb ver - callProcessStderr (Just "/") "cabal" [ "--package-db=clear" - , "--package-db=global" - , "--package-db=" ++ db - , "--prefix=" ++ db "prefix" - , "-j1" - , "install", "Cabal-"++showVersion ver - ] - return db - -createPkgDb :: Version -> IO FilePath -createPkgDb ver = do - db <- cabalPkgDb ver - exists <- doesDirectoryExist db - when (not exists) $ callProcessStderr Nothing "ghc-pkg" ["init", db] - return db - -cabalPkgDb :: Version -> IO FilePath -cabalPkgDb ver = do +installCabal :: Options -> Version -> IO FilePath +installCabal opts ver = do appdir <- appDataDir - return $ appdir "cabal-" ++ showVersion ver ++ "-db" + hPutStr stderr $ printf "\ +\cabal-helper-wrapper: Installing a private copy of Cabal, this might take a\n\ +\while but will only happen once per Cabal version.\n\ +\\n\ +\If anything goes horribly wrong just delete this directory and try again:\n\ +\ %s\n\ +\\n\ +\If you want to avoid this automatic installation altogether install version\n\ +\%s of Cabal manually (into your use or global package-db):\n\ +\ $ cabal install Cabal-%s\n\ +\..." appdir (showVersion ver) (showVersion ver) -cabalPkgDbExists :: Version -> IO Bool -cabalPkgDbExists ver = do - db <- cabalPkgDb ver + db <- createPkgDb opts ver + callProcessStderr (Just "/") (cabalProgram opts) $ concat + [ + [ "--package-db=clear" + , "--package-db=global" + , "--package-db=" ++ db + , "--prefix=" ++ db "prefix" + , "-v0" + , "--with-ghc=" ++ ghcProgram opts + ] + , if ghcPkgProgram opts /= ghcPkgProgram defaultOptions + then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ] + else [] + , [ "install", "Cabal-"++showVersion ver ] + ] + hPutStrLn stderr "Done" + return db + +ghcVersion :: Options -> IO Version +ghcVersion Options {..} = do + parseVer . trim <$> readProcess ghcProgram ["--numeric-version"] "" + +ghcPkgVersion :: Options -> IO Version +ghcPkgVersion Options {..} = do + parseVer . trim <$> readProcess ghcPkgProgram ["--numeric-version"] "" + +trim :: String -> String +trim = dropWhileEnd isSpace + +createPkgDb :: Options -> Version -> IO FilePath +createPkgDb opts@Options {..} ver = do + db <- cabalPkgDb opts ver + exists <- doesDirectoryExist db + when (not exists) $ callProcessStderr Nothing ghcPkgProgram ["init", db] + return db + +cabalPkgDb :: Options -> Version -> IO FilePath +cabalPkgDb opts ver = do + appdir <- appDataDir + ghcVer <- ghcVersion opts + return $ appdir "Cabal-" ++ showVersion ver ++ "-db-" ++ showVersion ghcVer + +cabalPkgDbExists :: Options -> Version -> IO Bool +cabalPkgDbExists opts ver = do + db <- cabalPkgDb opts ver dexists <- doesDirectoryExist db case dexists of False -> return False True -> do - vers <- listCabalVersions' (Just db) + vers <- listCabalVersions' opts (Just db) return $ ver `elem` vers -listCabalVersions :: IO [Version] -listCabalVersions = listCabalVersions' Nothing +listCabalVersions :: Options -> IO [Version] +listCabalVersions opts = listCabalVersions' opts Nothing -- TODO: Include sandbox? Probably only relevant for build-type:custom projects. -listCabalVersions' :: Maybe FilePath -> IO [Version] -listCabalVersions' mdb = do +listCabalVersions' :: Options -> Maybe FilePath -> IO [Version] +listCabalVersions' Options {..} mdb = do let mdbopt = ("--package-db="++) <$> mdb opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt catMaybes . map (fmap snd . parsePkgId . fromString) . words - <$> readProcess "ghc-pkg" opts "" + <$> readProcess ghcPkgProgram opts "" -- | Find @version: XXX@ delcaration in a cabal file cabalFileVersion :: String -> Version diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 5b5661e..27fd71d 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -58,16 +58,20 @@ getComponents = cabalHelper >>= \CabalHelper {..} -> return $ let GmComponent cn opts srcOpts ep ep srcDirs mempty in sc:cs - withCabal :: (MonadIO m, GmEnv m) => m a -> m a withCabal action = do crdl <- cradle - Options { cabalProgram } <- options - + opts <- options liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $ - withDirectory_ (cradleRootDir crdl) $ - void $ readProcess cabalProgram ["configure"] "" - + withDirectory_ (cradleRootDir crdl) $ do + let progOpts = + [ "--with-ghc=" ++ ghcProgram opts ] + -- Only pass ghc-pkg if it was actually set otherwise we + -- might break cabal's guessing logic + ++ if ghcPkgProgram opts /= ghcPkgProgram defaultOptions + then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ] + else [] + void $ readProcess (cabalProgram opts) ("configure":progOpts) "" action data CabalHelper = CabalHelper { @@ -81,19 +85,27 @@ data CabalHelper = CabalHelper { cabalHelper :: (MonadIO m, GmEnv m) => m CabalHelper cabalHelper = withCabal $ do Cradle {..} <- cradle - let cmds = [ "entrypoints" + Options {..} <- options + let args = [ "entrypoints" , "source-dirs" , "ghc-options" , "ghc-src-options" - , "ghc-pkg-options" ] + , "ghc-pkg-options" + , "--with-ghc=" ++ ghcProgram + , "--with-ghc-pkg=" ++ ghcPkgProgram + , "--with-cabal=" ++ cabalProgram + ] + distdir = cradleRootDir "dist" - exe <- liftIO $ findLibexecExe "cabal-helper-wrapper" - hexe <- liftIO $ readProcess exe [distdir, "print-exe"] "" - res <- liftIO $ cached cradleRootDir (cabalHelperCache hexe cmds) $ do - out <- readProcess exe (distdir:cmds) "" - evaluate (read out) `E.catch` - \(SomeException _) -> error "cabalHelper: read failed" + res <- liftIO $ do + exe <- findLibexecExe "cabal-helper-wrapper" + hexe <- readProcess exe [distdir, "print-exe"] "" + + cached cradleRootDir (cabalHelperCache hexe args) $ do + out <- readProcess exe (distdir:args) "" + evaluate (read out) `E.catch` + \(SomeException _) -> error "cabalHelper: read failed" let [ Just (GmCabalHelperEntrypoints eps), Just (GmCabalHelperStrings srcDirs), diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 1f11c96..f4310c7 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -47,8 +47,10 @@ data Options = Options { , lineSeparator :: LineSeparator -- | Verbosity , logLevel :: GmLogLevel --- -- | @ghc@ program name. --- , ghcProgram :: FilePath + -- | @ghc@ program name. + , ghcProgram :: FilePath + -- | @ghc-pkg@ program name. + , ghcPkgProgram :: FilePath -- | @cabal@ program name. , cabalProgram :: FilePath -- | GHC command line options set on the @ghc-mod@ command line @@ -68,8 +70,9 @@ defaultOptions :: Options defaultOptions = Options { outputStyle = PlainStyle , lineSeparator = LineSeparator "\0" - , logLevel = GmException --- , ghcProgram = "ghc" + , logLevel = GmInfo + , ghcProgram = "ghc" + , ghcPkgProgram = "ghc-pkg" , cabalProgram = "cabal" , ghcUserOptions= [] , operators = False diff --git a/src/GHCMod.hs b/src/GHCMod.hs index b086a9a..5fa7deb 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -281,8 +281,11 @@ globalArgSpec = reqArg "OPT" $ \g o -> o { ghcUserOptions = g : ghcUserOptions o } --- , option "" ["with-ghc"] "GHC executable to use" $ --- reqArg "PROG" $ \p o -> o { ghcProgram = p } + , option "" ["with-ghc"] "GHC executable to use" $ + reqArg "PROG" $ \p o -> o { ghcProgram = p } + + , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $ + reqArg "PROG" $ \p o -> o { ghcPkgProgram = p } , option "" ["with-cabal"] "cabal-install executable to use" $ reqArg "PROG" $ \p o -> o { cabalProgram = p } From a6d3f477bc36efc6b85c69a0306e1ab04c79f5d0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 8 Mar 2015 17:32:17 +0100 Subject: [PATCH 041/207] Add better handling for empty component assignments --- Language/Haskell/GhcMod/Target.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 2fb085e..28fca94 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -172,11 +172,19 @@ targetGhcOptions crdl sefnmn = do let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn candidates = Set.unions $ map snd mdlcs - when (Set.null candidates) $ - throwError $ GMECabalCompAssignment mdlcs + let noCandidates = Set.null candidates + noModuleHasAnyAssignment = all (Set.null . snd) mdlcs - let cn = pickComponent candidates - return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs + if noCandidates && noModuleHasAnyAssignment + then do + gmLog GmWarning "" $ strDoc $ "Could not find a componenet assignment, falling back to sandbox only project options." + sandboxOpts crdl + else do + when noCandidates $ + throwError $ GMECabalCompAssignment mdlcs + + let cn = pickComponent candidates + return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs moduleComponents :: Map GmComponentName (GmComponent (Set ModulePath)) -> Either FilePath ModuleName From 1ac71364a97e4339313366e49f860faa63c2be8b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 8 Mar 2015 17:33:09 +0100 Subject: [PATCH 042/207] Fix use of (head . lines) --- Language/Haskell/GhcMod/Logging.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 26a7205..4fd006d 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -56,8 +56,8 @@ gmLog level loc' doc = do GhcModLog { gmLogLevel = level' } <- gmlHistory let loc | loc' == "" = empty - | otherwise = text (head $ lines loc') <> colon - msg = gmRenderDoc $ gmLogLevelDoc level <+> loc <+> doc + | otherwise = text loc' + msg = gmRenderDoc $ (gmLogLevelDoc level <+> loc) <+>: doc msg' = dropWhileEnd isSpace msg when (Just level <= level') $ From 7d7f848afb1829daf969add10a158b8bfddc4497 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 8 Mar 2015 20:18:36 +0100 Subject: [PATCH 043/207] Fix cabal-helper ignoring --with-* flags --- CabalHelper/Wrapper.hs | 14 +++++++------- Language/Haskell/GhcMod/CabalHelper.hs | 13 ++++++++----- 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs index eef1fd4..34f5f9c 100644 --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -95,15 +95,15 @@ parseCommandArgs opts argv guessProgramPaths :: Options -> IO Options guessProgramPaths opts = do - mghcPkg <- guessToolFromGhcPath "ghc-pkg" (ghcProgram opts) - let guessedGhcPkg = fromMaybe (ghcPkgProgram dopts) mghcPkg - return opts { - ghcPkgProgram = if guessGhcPkg then guessedGhcPkg else ghcPkgProgram dopts - } + if not (same ghcProgram opts dopts) && same ghcPkgProgram opts dopts + then do + mghcPkg <- guessToolFromGhcPath "ghc-pkg" (ghcProgram opts) + return opts { + ghcPkgProgram = fromMaybe (ghcPkgProgram opts) mghcPkg + } + else return opts where - guessGhcPkg = nsame ghcProgram opts dopts && same ghcPkgProgram opts dopts same f o o' = f o == f o' - nsame f o o' = f o /= f o' dopts = defaultOptions main :: IO () diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 27fd71d..46e512c 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -34,6 +34,7 @@ import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World import Language.Haskell.GhcMod.PathsAndFiles import System.FilePath +import System.Process -- | Only package related GHC options, sufficient for things that don't need to -- access home modules @@ -86,21 +87,23 @@ cabalHelper :: (MonadIO m, GmEnv m) => m CabalHelper cabalHelper = withCabal $ do Cradle {..} <- cradle Options {..} <- options + let progArgs = [ "--with-ghc=" ++ ghcProgram + , "--with-ghc-pkg=" ++ ghcPkgProgram + , "--with-cabal=" ++ cabalProgram + ] + let args = [ "entrypoints" , "source-dirs" , "ghc-options" , "ghc-src-options" , "ghc-pkg-options" - , "--with-ghc=" ++ ghcProgram - , "--with-ghc-pkg=" ++ ghcPkgProgram - , "--with-cabal=" ++ cabalProgram - ] + ] ++ progArgs distdir = cradleRootDir "dist" res <- liftIO $ do exe <- findLibexecExe "cabal-helper-wrapper" - hexe <- readProcess exe [distdir, "print-exe"] "" + hexe <- readProcess exe ([distdir, "print-exe"] ++ progArgs) "" cached cradleRootDir (cabalHelperCache hexe args) $ do out <- readProcess exe (distdir:args) "" From 539c294dd455f61d3f0c14b2cb8b95cf1633f732 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 9 Mar 2015 22:04:04 +0100 Subject: [PATCH 044/207] Fix a bunch of relate exception handling problems should handle exceptions outside of runGmlT otherwise we don't catch ghc load related ones. --- Language/Haskell/GhcMod/Browse.hs | 2 +- Language/Haskell/GhcMod/CaseSplit.hs | 2 +- Language/Haskell/GhcMod/Check.hs | 4 ++-- Language/Haskell/GhcMod/FillSig.hs | 8 ++++---- Language/Haskell/GhcMod/Info.hs | 12 ++++++------ Language/Haskell/GhcMod/Monad.hs | 6 +++--- Language/Haskell/GhcMod/Monad/Types.hs | 26 +++++++++++++------------- Language/Haskell/GhcMod/Target.hs | 23 +++++++++++------------ 8 files changed, 41 insertions(+), 42 deletions(-) diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 55a8afb..bc45f82 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -42,7 +42,7 @@ browse pkgmdl = do runGmPkgGhc $ processExports opt =<< tryModuleInfo =<< G.findModule mdlname mpkgid - goHomeModule = runGmLoadedT [Right mdlname] $ do + goHomeModule = runGmlT [Right mdlname] $ do opt <- options processExports opt =<< tryModuleInfo =<< G.findModule mdlname Nothing diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index f33f5cf..890bee0 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -46,7 +46,7 @@ splits :: IOish m -> Int -- ^ Column number. -> GhcModT m String splits file lineNo colNo = - runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do + ghandle handler $ runGmlT' [Left file] deferErrors $ do opt <- options crdl <- cradle style <- getStyle diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index 92715fe..cdc5b14 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -29,7 +29,7 @@ check :: IOish m => [FilePath] -- ^ The target files. -> GhcModT m (Either String String) check files = - runGmLoadedTWith + runGmlTWith (map Left files) return ((fmap fst <$>) . withLogger (setAllWarningFlags . setNoMaxRelevantBindings)) @@ -49,7 +49,7 @@ expandTemplate files = either id id <$> expand files -- | Expanding Haskell Template. expand :: IOish m => [FilePath] -> GhcModT m (Either String String) expand files = - runGmLoadedTWith + runGmlTWith (map Left files) return ((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags)) diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 93d75ee..12a6e6b 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -69,7 +69,7 @@ sig :: IOish m -> Int -- ^ Column number. -> GhcModT m String sig file lineNo colNo = - runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do + runGmlT' [Left file] deferErrors $ ghandle fallback $ do opt <- options style <- getStyle dflag <- G.getSessionDynFlags @@ -91,7 +91,7 @@ sig file lineNo colNo = where - handler (SomeException _) = do + fallback (SomeException _) = do opt <- options -- Code cannot be parsed by ghc module -- Fallback: try to get information via haskell-src-exts @@ -332,7 +332,7 @@ refine :: IOish m -> Expression -- ^ A Haskell expression. -> GhcModT m String refine file lineNo colNo expr = - runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do + ghandle handler $ runGmlT' [Left file] deferErrors $ do opt <- options style <- getStyle dflag <- G.getSessionDynFlags @@ -399,7 +399,7 @@ auto :: IOish m -> Int -- ^ Column number. -> GhcModT m String auto file lineNo colNo = - runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do + ghandle handler $ runGmlT' [Left file] deferErrors $ do opt <- options style <- getStyle dflag <- G.getSessionDynFlags diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index b376c90..0fa74e2 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -3,7 +3,7 @@ module Language.Haskell.GhcMod.Info ( , types ) where -import Control.Applicative ((<$>)) +import Control.Applicative import Data.Function (on) import Data.List (sortBy) import Data.Maybe (catMaybes) @@ -29,14 +29,14 @@ info :: IOish m => FilePath -- ^ A target file. -> Expression -- ^ A Haskell expression. -> GhcModT m String -info file expr = runGmLoadedT' [Left file] deferErrors $ withContext $ do - opt <- options - convert opt <$> ghandle handler body +info file expr = + ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $ + convert <$> options <*> body where handler (SomeException ex) = do gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex) - return "Cannot show info" + convert' "Cannot show info" body = do sdoc <- Gap.infoThing expr @@ -54,7 +54,7 @@ types :: IOish m -> Int -- ^ Column number. -> GhcModT m String types file lineNo colNo = - runGmLoadedT' [Left file] deferErrors $ ghandle handler $ withContext $ do + ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $ do crdl <- cradle modSum <- Gap.fileModSummary (cradleCurrentDir crdl file) srcSpanTypes <- getSrcSpanType modSum lineNo colNo diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index e10a707..8f89f1c 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -20,9 +20,9 @@ module Language.Haskell.GhcMod.Monad ( , runGhcModT' , runGhcModT'' , hoistGhcModT - , runGmLoadedT - , runGmLoadedT' - , runGmLoadedTWith + , runGmlT + , runGmlT' + , runGmlTWith , runGmPkgGhc , withGhcModEnv , withGhcModEnv' diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index e4c18cb..9d7f979 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -23,7 +23,7 @@ module Language.Haskell.GhcMod.Monad.Types ( -- * Monad Types GhcModT(..) - , GmLoadedT(..) + , GmlT(..) , LightGhc(..) , GmGhc , IOish @@ -164,7 +164,7 @@ newtype GhcModT m a = GhcModT { , MonadError GhcModError ) -newtype GmLoadedT m a = GmLoadedT { unGmLoadedT :: GhcModT m a } +newtype GmlT m a = GmlT { unGmlT :: GhcModT m a } deriving ( Functor , Applicative , Alternative @@ -307,20 +307,20 @@ instance MonadIO m => MonadIO (MaybeT m) where liftIO = lift . liftIO #endif -instance (MonadBaseControl IO m) => MonadBase IO (GmLoadedT m) where - liftBase = GmLoadedT . liftBase +instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where + liftBase = GmlT . liftBase -instance (MonadBaseControl IO m) => MonadBaseControl IO (GmLoadedT m) where - type StM (GmLoadedT m) a = StM (GhcModT m) a +instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where + type StM (GmlT m) a = StM (GhcModT m) a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} -instance MonadTransControl GmLoadedT where - type StT GmLoadedT a = StT GhcModT a - liftWith = defaultLiftWith GmLoadedT unGmLoadedT - restoreT = defaultRestoreT GmLoadedT +instance MonadTransControl GmlT where + type StT GmlT a = StT GhcModT a + liftWith = defaultLiftWith GmlT unGmlT + restoreT = defaultRestoreT GmlT instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where liftBase = GhcModT . liftBase @@ -366,7 +366,7 @@ gmLiftWithInner f = liftWith f >>= restoreT . return type GmGhc m = (IOish m, GhcMonad m) -instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmLoadedT m) where +instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where getSession = do ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet liftIO $ readIORef ref @@ -379,7 +379,7 @@ instance GhcMonad LightGhc where setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask #if __GLASGOW_HASKELL__ >= 706 -instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmLoadedT m) where +instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where getDynFlags = hsc_dflags <$> getSession instance HasDynFlags LightGhc where @@ -393,7 +393,7 @@ instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GhcModT m) where gmask = liftBaseOp gmask . liftRestore where liftRestore f r = f $ liftBaseOp_ r -instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmLoadedT m) where +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmlT m) where gcatch act handler = control $ \run -> run act `gcatch` (run . handler) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 28fca94..994c687 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -117,24 +117,23 @@ initSession opts mdf = do -- ( setModeSimple -- $ setEmptyLogger -- df) -runGmLoadedT :: IOish m - => [Either FilePath ModuleName] -> GmLoadedT m a -> GhcModT m a -runGmLoadedT fns action = runGmLoadedT' fns return action +runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a +runGmlT fns action = runGmlT' fns return action -runGmLoadedT' :: IOish m +runGmlT' :: IOish m => [Either FilePath ModuleName] -> (DynFlags -> Ghc DynFlags) - -> GmLoadedT m a + -> GmlT m a -> GhcModT m a -runGmLoadedT' fns mdf action = runGmLoadedTWith fns mdf id action +runGmlT' fns mdf action = runGmlTWith fns mdf id action -runGmLoadedTWith :: IOish m +runGmlTWith :: IOish m => [Either FilePath ModuleName] -> (DynFlags -> Ghc DynFlags) - -> (GmLoadedT m a -> GmLoadedT m b) - -> GmLoadedT m a + -> (GmlT m a -> GmlT m b) + -> GmlT m a -> GhcModT m b -runGmLoadedTWith efnmns' mdf wrapper action = do +runGmlTWith efnmns' mdf wrapper action = do crdl <- cradle Options { ghcUserOptions } <- options @@ -150,7 +149,7 @@ runGmLoadedTWith efnmns' mdf wrapper action = do initSession opts' $ setModeSimple >>> setEmptyLogger >>> mdf - unGmLoadedT $ wrapper $ do + unGmlT $ wrapper $ do loadTargets (map moduleNameString mns ++ rfns) action @@ -293,7 +292,7 @@ resolveGmComponents mumns cs = do -- | Set the files as targets and load them. -loadTargets :: IOish m => [String] -> GmLoadedT m () +loadTargets :: IOish m => [String] -> GmlT m () loadTargets filesOrModules = do gmLog GmDebug "loadTargets" $ text "Loading" <+>: fsep (map text filesOrModules) From 3f8cfadeffb5ff4045b3de63fe5552172564b54a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 10 Mar 2015 09:24:33 +0100 Subject: [PATCH 045/207] Fix overlapping global/command flag `-q` --- src/GHCMod.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 5fa7deb..4a6c680 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -266,7 +266,7 @@ globalArgSpec = \ be more verbose." $ NoArg $ \o -> o { logLevel = increaseLogLevel (logLevel o) } - , option "q" [] "Can be given multiple times to be increasingly be less\ + , option "s" [] "Can be given multiple times to be increasingly be less\ \ verbose." $ NoArg $ \o -> o { logLevel = decreaseLogLevel (logLevel o) } From 44dddadda33b4058ac3074f533a6fa0375553c01 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 10 Mar 2015 23:57:28 +0100 Subject: [PATCH 046/207] Fix travis-ci --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 32f4ede..fd3a6b1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -12,6 +12,7 @@ install: - which cabal - cabal install cabal-install --constraint "Cabal == $(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | awk -vFS=. '{ print $1 "." $2 }' | tail -n1).*" # - cabal install Cabal --constraint "Cabal == $(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | tail -n1)" + - cabal install happy - happy --version - cabal install -j --only-dependencies --enable-tests From 1cc9c4ba3d34590f2e3c78ee932fcc99942dcdd8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 11 Mar 2015 13:17:02 +0100 Subject: [PATCH 047/207] Also fix ghc and mtl version in doctest --- test/doctests.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/doctests.hs b/test/doctests.hs index 0337cc9..a591638 100644 --- a/test/doctests.hs +++ b/test/doctests.hs @@ -5,8 +5,9 @@ import Test.DocTest main :: IO () main = doctest - [ "-package", "ghc" + [ "-package", "ghc-" ++ VERSION_ghc , "-package", "transformers-" ++ VERSION_transformers + , "-package", "mtl-" ++ VERSION_mtl , "-package", "directory-" ++ VERSION_directory , "-XConstraintKinds", "-XFlexibleContexts", "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns" , "-idist/build/autogen/" From 6756f1d10b2dbf045851c014c5dde001e0704001 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 11 Mar 2015 13:17:24 +0100 Subject: [PATCH 048/207] Get rid of some warnings with ghc-7.8 --- Language/Haskell/GhcMod/CabalHelper.hs | 1 - Language/Haskell/GhcMod/Types.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 46e512c..f674157 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -34,7 +34,6 @@ import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World import Language.Haskell.GhcMod.PathsAndFiles import System.FilePath -import System.Process -- | Only package related GHC options, sufficient for things that don't need to -- access home modules diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index f4310c7..352b658 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, GADTs, StandaloneDeriving, DataKinds #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} module Language.Haskell.GhcMod.Types ( module Language.Haskell.GhcMod.Types , module CabalHelper.Types From a97e07065ece6cd651c5fb6639b567eb6c501fd7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 15 Mar 2015 20:33:39 +0100 Subject: [PATCH 049/207] Don't set -Wall on `check` --- Language/Haskell/GhcMod/Check.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index cdc5b14..5820bf0 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -32,7 +32,7 @@ check files = runGmlTWith (map Left files) return - ((fmap fst <$>) . withLogger (setAllWarningFlags . setNoMaxRelevantBindings)) + ((fmap fst <$>) . withLogger setNoMaxRelevantBindings) (return ()) ---------------------------------------------------------------- From 90d9577f8d294c9aafc3c973e71b50c3b2291215 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 15 Mar 2015 20:48:55 +0100 Subject: [PATCH 050/207] Factor out cabal-helper into a package --- CabalHelper/Common.hs | 98 ------ CabalHelper/GuessGhc.hs | 83 ----- CabalHelper/Main.hs | 344 ------------------- CabalHelper/Types.hs | 18 - CabalHelper/Wrapper.hs | 418 ----------------------- Language/Haskell/GhcMod.hs | 2 + Language/Haskell/GhcMod/CabalHelper.hs | 108 ++---- Language/Haskell/GhcMod/Monad/Types.hs | 3 +- Language/Haskell/GhcMod/PathsAndFiles.hs | 12 +- Language/Haskell/GhcMod/Pretty.hs | 13 +- Language/Haskell/GhcMod/Target.hs | 37 +- Language/Haskell/GhcMod/Types.hs | 12 +- ghc-mod.cabal | 24 +- 13 files changed, 90 insertions(+), 1082 deletions(-) delete mode 100644 CabalHelper/Common.hs delete mode 100644 CabalHelper/GuessGhc.hs delete mode 100644 CabalHelper/Main.hs delete mode 100644 CabalHelper/Types.hs delete mode 100644 CabalHelper/Wrapper.hs diff --git a/CabalHelper/Common.hs b/CabalHelper/Common.hs deleted file mode 100644 index 884c486..0000000 --- a/CabalHelper/Common.hs +++ /dev/null @@ -1,98 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -module CabalHelper.Common where - -import Control.Applicative -import Control.Exception as E -import Control.Monad -import Data.List -import Data.Maybe -import Data.Version -import Data.Typeable -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import System.Environment -import System.IO -import System.Exit -import Text.ParserCombinators.ReadP - -data Panic = Panic String deriving (Typeable, Show) -instance Exception Panic - -panic :: String -> a -panic msg = throw $ Panic msg - -handlePanic :: IO a -> IO a -handlePanic action = - action `E.catch` \(Panic msg) -> errMsg msg >> exitFailure - -errMsg :: String -> IO () -errMsg str = do - prog <- getProgName - hPutStrLn stderr $ prog ++ ": " ++ str - -align :: String -> String -> String -> String -align n an str = let - h:rest = lines str - [hm] = match n h - rest' = [ move (hm - rm) r | r <- rest, rm <- match an r] - in - unlines (h:rest') - where - match p str' = maybeToList $ - fst <$> find ((p `isPrefixOf`) . snd) ([0..] `zip` tails str') - move i str' | i > 0 = replicate i ' ' ++ str' - move i str' = drop i str' - - --- | @getCabalConfigHeader "dist/setup-config"@ returns the cabal version and --- compiler version -getCabalConfigHeader :: FilePath -> IO (Maybe (Version, Version)) -getCabalConfigHeader file = bracket (openFile file ReadMode) hClose $ \h -> do - parseHeader <$> BS.hGetLine h - -parseHeader :: ByteString -> Maybe (Version, Version) -parseHeader header = case BS8.words header of - ["Saved", "package", "config", "for", _pkgId , - "written", "by", cabalId, - "using", compId] - -> liftM2 (,) (ver cabalId) (ver compId) - _ -> Nothing - where - ver i = snd <$> parsePkgId i - -parsePkgId :: ByteString -> Maybe (ByteString, Version) -parsePkgId bs = - case BS8.split '-' bs of - [pkg, vers] -> Just (pkg, parseVer $ BS8.unpack vers) - _ -> Nothing - -parseVer :: String -> Version -parseVer vers = runReadP parseVersion vers - --- majorVer :: Version -> Version --- majorVer (Version b _) = Version (take 2 b) [] - --- sameMajorVersion :: Version -> Version -> Bool --- sameMajorVersion a b = majorVer a == majorVer b - -runReadP :: ReadP t -> String -> t -runReadP p i = case filter ((=="") . snd) $ readP_to_S p i of - (a,""):[] -> a - _ -> error $ "Error parsing: " ++ show i diff --git a/CabalHelper/GuessGhc.hs b/CabalHelper/GuessGhc.hs deleted file mode 100644 index 0827456..0000000 --- a/CabalHelper/GuessGhc.hs +++ /dev/null @@ -1,83 +0,0 @@ -module CabalHelper.GuessGhc (guessToolFromGhcPath) where - -import Data.Maybe -import Data.Char -import Distribution.Simple.BuildPaths -import System.Directory -import System.FilePath - --- Copyright (c) 2003-2014, Isaac Jones, Simon Marlow, Martin Sjögren, --- Bjorn Bringert, Krasimir Angelov, --- Malcolm Wallace, Ross Patterson, Ian Lynagh, --- Duncan Coutts, Thomas Schilling, --- Johan Tibell, Mikhail Glushenkov --- All rights reserved. - --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: - --- * Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. - --- * Redistributions in binary form must reproduce the above --- copyright notice, this list of conditions and the following --- disclaimer in the documentation and/or other materials provided --- with the distribution. - --- * Neither the name of Isaac Jones nor the names of other --- contributors may be used to endorse or promote products derived --- from this software without specific prior written permission. - --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR --- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT --- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT --- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, --- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY --- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT --- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE --- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -guessToolFromGhcPath :: FilePath -- ^ Tool name - -> FilePath -- ^ GHC exe path - -> IO (Maybe FilePath) -guessToolFromGhcPath toolname ghcPath - = do let - path = ghcPath - dir = takeDirectory path - versionSuffix = takeVersionSuffix (dropExeExtension path) - guessNormal = dir toolname <.> exeExtension - guessGhcVersioned = dir (toolname ++ "-ghc" ++ versionSuffix) - <.> exeExtension - guessVersioned = dir (toolname ++ versionSuffix) - <.> exeExtension - guesses | null versionSuffix = [guessNormal] - | otherwise = [guessGhcVersioned, - guessVersioned, - guessNormal] - exists <- mapM doesFileExist guesses - return $ listToMaybe [ file | (file, True) <- zip guesses exists ] - - where takeVersionSuffix :: FilePath -> String - takeVersionSuffix = takeWhileEndLE isSuffixChar - - isSuffixChar :: Char -> Bool - isSuffixChar c = isDigit c || c == '.' || c == '-' - - dropExeExtension :: FilePath -> FilePath - dropExeExtension filepath = - case splitExtension filepath of - (filepath', extension) | extension == exeExtension -> filepath' - | otherwise -> filepath - --- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but --- is usually faster (as well as being easier to read). -takeWhileEndLE :: (a -> Bool) -> [a] -> [a] -takeWhileEndLE p = fst . foldr go ([], False) - where - go x (rest, done) - | not done && p x = (x:rest, False) - | otherwise = (rest, True) diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs deleted file mode 100644 index ee1ae38..0000000 --- a/CabalHelper/Main.hs +++ /dev/null @@ -1,344 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE CPP, BangPatterns, RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} -import Distribution.Simple.Utils (cabalVersion) -import Distribution.Simple.Configure - -import Distribution.Package (PackageIdentifier, InstalledPackageId, PackageId) -import Distribution.PackageDescription (PackageDescription, - FlagAssignment, - Executable(..), - Library(..), - TestSuite(..), - Benchmark(..), - BuildInfo(..), - TestSuiteInterface(..), - BenchmarkInterface(..), - withLib) -import Distribution.PackageDescription.Parse (readPackageDescription) -import Distribution.PackageDescription.Configuration (flattenPackageDescription) - -import Distribution.Simple.Program (requireProgram, ghcProgram) -import Distribution.Simple.Program.Types (ConfiguredProgram(..)) -import Distribution.Simple.Configure (getPersistBuildConfig) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), - Component(..), - ComponentName(..), - ComponentLocalBuildInfo(..), - componentBuildInfo, - externalPackageDeps, - withComponentsLBI, - inplacePackageId) - -import Distribution.Simple.GHC (componentGhcOptions) -import Distribution.Simple.Program.GHC (GhcOptions(..), renderGhcOptions) - -import Distribution.Simple.Setup (ConfigFlags(..),Flag(..)) -import Distribution.Simple.Build (initialBuildSteps) -import Distribution.Simple.BuildPaths (autogenModuleName, cppHeaderName, exeExtension) -import Distribution.Simple.Compiler (PackageDB(..)) - -import Distribution.ModuleName (components) -import qualified Distribution.ModuleName as C (ModuleName) -import Distribution.Text (display) -import Distribution.Verbosity (Verbosity, silent, deafening) - -#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22 -import Distribution.Utils.NubList -#endif - -import Control.Applicative ((<$>)) -import Control.Monad -import Control.Exception (catch, PatternMatchFail(..)) -import Data.List -import Data.Maybe -import Data.Monoid -import Data.IORef -import System.Environment -import System.Directory -import System.FilePath -import System.Exit -import System.IO -import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO) -import Text.Printf - -import CabalHelper.Common -import CabalHelper.Types - -usage = do - prog <- getProgName - hPutStr stderr $ align "(" "|" ("Usage: " ++ prog ++ " " ++ usageMsg) - where - usageMsg = "" - ++"DIST_DIR ( version\n" - ++" | print-lbi\n" - ++" | write-autogen-files\n" - ++" | ghc-options [--with-inplace]\n" - ++" | ghc-src-options [--with-inplace]\n" - ++" | ghc-pkg-options [--with-inplace]\n" - ++" | entrypoints\n" - ++" | source-dirs\n" - ++" ) ...\n" - -commands :: [String] -commands = [ "print-bli" - , "write-autogen-files" - , "component-from-file" - , "ghc-options" - , "ghc-src-options" - , "ghc-pkg-options" - , "entrypoints" - , "source-dirs"] - -main :: IO () -main = do - args <- getArgs - - distdir:args' <- case args of - [] -> usage >> exitFailure - _ -> return args - - ddexists <- doesDirectoryExist distdir - when (not ddexists) $ do - errMsg $ "distdir '"++distdir++"' does not exist" - exitFailure - - v <- maybe silent (const deafening) . lookup "GHC_MOD_DEBUG" <$> getEnvironment - lbi <- unsafeInterleaveIO $ getPersistBuildConfig distdir - let pd = localPkgDescr lbi - - let - -- a =<< b $$ c == (a =<< b) $$ c - -- a <$$> b $$ c == a <$$> (b $$ c) - infixr 2 $$ - ($$) = ($) - infixr 1 <$$> - (<$$>) = (<$>) - - collectCmdOptions :: [String] -> [[String]] - collectCmdOptions = - reverse . map reverse . foldl f [] . dropWhile isOpt - where - isOpt = ("--" `isPrefixOf`) - f [] x = [[x]] - f (a:as) x - | isOpt x = (x:a):as - | otherwise = [x]:(a:as) - - let cmds = collectCmdOptions args' - - if any (["version"] `isPrefixOf`) cmds - then do - putStrLn $ - printf "using version %s of the Cabal library" (display cabalVersion) - exitSuccess - else return () - - print =<< flip mapM cmds $$ \cmd -> do - case cmd of - "write-autogen-files":[] -> do - let pd = localPkgDescr lbi - -- calls writeAutogenFiles - initialBuildSteps distdir pd lbi v - return Nothing - - "ghc-options":flags -> - Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ - \c clbi bi -> let - outdir = componentOutDir lbi c - (clbi', adopts) = case flags of - ["--with-inplace"] -> (clbi, mempty) - [] -> removeInplaceDeps pd clbi - opts = componentGhcOptions v lbi bi clbi' outdir - in - renderGhcOptions' lbi v $ opts `mappend` adopts - - "ghc-src-options":flags -> - Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ - \c clbi bi -> let - outdir = componentOutDir lbi c - (clbi', adopts) = case flags of - ["--with-inplace"] -> (clbi, mempty) - [] -> removeInplaceDeps pd clbi - opts = componentGhcOptions v lbi bi clbi' outdir - comp = compiler lbi - - opts' = mempty { - -- Not really needed but "unexpected package db stack: []" - ghcOptPackageDBs = [GlobalPackageDB], - ghcOptCppOptions = ghcOptCppOptions opts, - ghcOptCppIncludePath = ghcOptCppIncludePath opts, - ghcOptCppIncludes = ghcOptCppIncludes opts, - ghcOptFfiIncludes = ghcOptFfiIncludes opts, - ghcOptSourcePathClear = ghcOptSourcePathClear opts, - ghcOptSourcePath = ghcOptSourcePath opts - } - in - renderGhcOptions' lbi v $ opts `mappend` adopts - - "ghc-pkg-options":flags -> - Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ - \c clbi bi -> let - comp = compiler lbi - outdir = componentOutDir lbi c - (clbi', adopts) = case flags of - ["--with-inplace"] -> (clbi, mempty) - [] -> removeInplaceDeps pd clbi - opts = componentGhcOptions v lbi bi clbi' outdir - - opts' = mempty { - ghcOptPackageDBs = ghcOptPackageDBs opts, - ghcOptPackages = ghcOptPackages opts, - ghcOptHideAllPackages = ghcOptHideAllPackages opts - } - in - renderGhcOptions' lbi v $ opts' `mappend` adopts - - "entrypoints":[] -> do - eps <- componentsMap lbi v distdir $ \c clbi bi -> - return $ componentEntrypoints c - -- MUST append Setup component at the end otherwise CabalHelper gets - -- confused - let eps' = eps ++ [(GmSetupHsName, Right [GmModuleName "Setup"])] - return $ Just $ GmCabalHelperEntrypoints eps' - - "source-dirs":[] -> - Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ - \c clbi bi -> return $ hsSourceDirs bi - - "print-lbi":[] -> - return $ Just $ GmCabalHelperLbi $ show lbi - - cmd:_ | not (cmd `elem` commands) -> - errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure - _ -> - errMsg "Invalid usage!" >> usage >> exitFailure - - -getLibrary :: PackageDescription -> Library -getLibrary pd = unsafePerformIO $ do - lr <- newIORef (error "libraryMap: empty IORef") - withLib pd (writeIORef lr) - readIORef lr - -componentsMap :: LocalBuildInfo - -> Verbosity - -> FilePath - -> ( Component - -> ComponentLocalBuildInfo - -> BuildInfo - -> IO a) - -> IO [(GmComponentName, a)] -componentsMap lbi v distdir f = do - let pd = localPkgDescr lbi - - lr <- newIORef [] - - withComponentsLBI pd lbi $ \c clbi -> do - let bi = componentBuildInfo c - name = componentNameFromComponent c - - l' <- readIORef lr - r <- f c clbi bi - writeIORef lr $ (componentNameToGm name, r):l' - reverse <$> readIORef lr - -componentNameToGm CLibName = GmLibName -componentNameToGm (CExeName n) = GmExeName n -componentNameToGm (CTestName n) = GmTestName n -componentNameToGm (CBenchName n) = GmBenchName n - -componentNameFromComponent (CLib Library {}) = CLibName -componentNameFromComponent (CExe Executable {..}) = CExeName exeName -componentNameFromComponent (CTest TestSuite {..}) = CTestName testName -componentNameFromComponent (CBench Benchmark {..}) = CBenchName benchmarkName - -componentOutDir lbi (CLib Library {..})= buildDir lbi -componentOutDir lbi (CExe Executable {..})= exeOutDir lbi exeName -componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteExeV10 _ _, ..}) = - exeOutDir lbi testName -componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteLibV09 _ _, ..}) = - exeOutDir lbi (testName ++ "Stub") -componentOutDir lbi (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ _, ..})= - exeOutDir lbi benchmarkName - -gmModuleName :: C.ModuleName -> GmModuleName -gmModuleName = GmModuleName . intercalate "." . components - -componentEntrypoints :: Component -> Either FilePath [GmModuleName] -componentEntrypoints (CLib Library {..}) - = Right $ map gmModuleName $ exposedModules ++ (otherModules libBuildInfo) -componentEntrypoints (CExe Executable {..}) - = Left modulePath -componentEntrypoints (CTest TestSuite { testInterface = TestSuiteExeV10 _ fp }) - = Left fp -componentEntrypoints (CTest TestSuite { testInterface = TestSuiteLibV09 _ mn }) - = Right [gmModuleName mn] -componentEntrypoints (CTest TestSuite {}) - = Right [] -componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ fp}) - = Left fp -componentEntrypoints (CBench Benchmark {}) - = Left [] - -exeOutDir :: LocalBuildInfo -> String -> FilePath -exeOutDir lbi exeName = - ----- Copied from Distribution/Simple/GHC.hs:buildOrReplExe - -- exeNameReal, the name that GHC really uses (with .exe on Windows) - let exeNameReal = exeName <.> - (if takeExtension exeName /= ('.':exeExtension) - then exeExtension - else "") - - targetDir = (buildDir lbi) exeName - in targetDir - - -removeInplaceDeps :: PackageDescription - -> ComponentLocalBuildInfo - -> (ComponentLocalBuildInfo, GhcOptions) -removeInplaceDeps pd clbi = let - (ideps, deps) = partition isInplaceDep (componentPackageDeps clbi) - hasIdeps = not $ null ideps - clbi' = clbi { componentPackageDeps = deps } - lib = getLibrary pd - src_dirs = hsSourceDirs (libBuildInfo lib) - adopts = mempty { - ghcOptSourcePath = -#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22 - toNubListR src_dirs -#else - src_dirs -#endif - - } - - in (clbi', if hasIdeps then adopts else mempty) - - where - isInplaceDep :: (InstalledPackageId, PackageId) -> Bool - isInplaceDep (ipid, pid) = inplacePackageId pid == ipid - -renderGhcOptions' lbi v opts = do -#if CABAL_MAJOR == 1 && CABAL_MINOR < 20 - (ghcProg, _) <- requireProgram v ghcProgram (withPrograms lbi) - let Just ghcVer = programVersion ghcProg - return $ renderGhcOptions ghcVer opts -#else - return $ renderGhcOptions (compiler lbi) opts -#endif diff --git a/CabalHelper/Types.hs b/CabalHelper/Types.hs deleted file mode 100644 index 273df7d..0000000 --- a/CabalHelper/Types.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE CPP #-} -module CabalHelper.Types where - -newtype GmModuleName = GmModuleName String - deriving (Read, Show) - -data GmComponentName = GmSetupHsName - | GmLibName - | GmExeName String - | GmTestName String - | GmBenchName String - deriving (Eq, Ord, Read, Show) - -data GmCabalHelperResponse - = GmCabalHelperStrings [(GmComponentName, [String])] - | GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [GmModuleName])] - | GmCabalHelperLbi String - deriving (Read, Show) diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs deleted file mode 100644 index 34f5f9c..0000000 --- a/CabalHelper/Wrapper.hs +++ /dev/null @@ -1,418 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - -{-# LANGUAGE TemplateHaskell, RecordWildCards, FlexibleContexts #-} -module Main where - -import Control.Applicative -import Control.Arrow -import Control.Exception as E -import Control.Monad -import Control.Monad.Trans.Maybe -import Control.Monad.IO.Class -import Data.Char -import Data.List -import Data.Maybe -import Data.String -import Data.Version -import Text.Printf -import System.Console.GetOpt -import System.Environment -import System.Directory -import System.FilePath -import System.Process -import System.Exit -import System.IO - -import Distribution.System (buildPlatform) -import Distribution.Text (display) - -import NotCPP.Declarations - -import Paths_ghc_mod -import CabalHelper.Common -import CabalHelper.GuessGhc -import Utils - -ifD [d| getExecutablePath = getProgName |] - -usage :: IO () -usage = do - prog <- getProgName - hPutStr stderr $ align "(" "|" ("Usage: " ++ prog ++ " " ++ usageMsg) - where - usageMsg = "\ -\( print-appdatadir\n\ -\| print-build-platform\n\ -\| DIST_DIR ( print-exe | [CABAL_HELPER_ARGS...] ) )\n" - -data Options = Options { - ghcProgram :: FilePath - , ghcPkgProgram :: FilePath - , cabalProgram :: FilePath -} - -defaultOptions :: Options -defaultOptions = Options "ghc" "ghc-pkg" "cabal" - -globalArgSpec :: [OptDescr (Options -> Options)] -globalArgSpec = - [ option "" ["with-ghc"] "GHC executable to use" $ - reqArg "PROG" $ \p o -> o { ghcProgram = p } - - , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $ - reqArg "PROG" $ \p o -> o { ghcPkgProgram = p } - - , option "" ["with-cabal"] "cabal-install executable to use" $ - reqArg "PROG" $ \p o -> o { cabalProgram = p } - ] - where - option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a - option s l udsc dsc = Option s l dsc udsc - - reqArg :: String -> (String -> a) -> ArgDescr a - reqArg udsc dsc = ReqArg dsc udsc - -parseCommandArgs :: Options -> [String] -> (Options, [String]) -parseCommandArgs opts argv - = case getOpt Permute globalArgSpec argv of - (o,r,[]) -> (foldr id opts o, r) - (_,_,errs) -> - panic $ "Parsing command options failed: " ++ concat errs - -guessProgramPaths :: Options -> IO Options -guessProgramPaths opts = do - if not (same ghcProgram opts dopts) && same ghcPkgProgram opts dopts - then do - mghcPkg <- guessToolFromGhcPath "ghc-pkg" (ghcProgram opts) - return opts { - ghcPkgProgram = fromMaybe (ghcPkgProgram opts) mghcPkg - } - else return opts - where - same f o o' = f o == f o' - dopts = defaultOptions - -main :: IO () -main = handlePanic $ do - (opts', args) <- parseCommandArgs defaultOptions <$> getArgs - opts <- guessProgramPaths opts' - case args of - [] -> usage - "--help":[] -> usage - "print-appdatadir":[] -> putStrLn =<< appDataDir - "print-build-platform":[] -> putStrLn $ display buildPlatform - distdir:args' -> do - cfgf <- canonicalizePath (distdir "setup-config") - mhdr <- getCabalConfigHeader cfgf - case mhdr of - Nothing -> panic $ printf "\ -\Could not read Cabal's persistent setup configuration header\n\ -\- Check first line of: %s\n\ -\- Maybe try: $ cabal configure" cfgf - - Just (hdrCabalVersion, _hdrCompilerVersion) -> do - eexe <- compileHelper opts hdrCabalVersion - case eexe of - Left e -> exitWith e - Right exe -> - case args' of - "print-exe":_ -> putStrLn exe - _ -> do - (_,_,_,h) <- createProcess $ proc exe args - exitWith =<< waitForProcess h - -appDataDir :: IO FilePath -appDataDir = ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" - -tryFindSrcDirInGhcModTree :: IO (Maybe FilePath) -tryFindSrcDirInGhcModTree = do - dir <- (!!4) . iterate takeDirectory <$> getExecutablePath - exists <- doesFileExist $ dir "ghc-mod.cabal" - src_exists <- doesFileExist $ dir "CabalHelper/Main.hs" - if exists && src_exists - then return $ Just dir - else return Nothing - -tryFindRealSrcDir :: IO (Maybe FilePath) -tryFindRealSrcDir = do - datadir <- getDataDir - exists <- doesFileExist $ datadir "CabalHelper/Main.hs" - return $ if exists - then Just datadir - else Nothing - -findCabalHelperSourceDir :: IO FilePath -findCabalHelperSourceDir = do - msrcdir <- runMaybeT $ MaybeT tryFindSrcDirInGhcModTree - <|> MaybeT tryFindRealSrcDir - case msrcdir of - Nothing -> getDataDir >>= errorNoMain - Just datadir -> return datadir - -compileHelper :: Options -> Version -> IO (Either ExitCode FilePath) -compileHelper opts cabalVer = do - chdir <- findCabalHelperSourceDir - run [ Right <$> MaybeT (cachedExe cabalVer chdir) - , compileGlobal chdir - , cachedCabalPkg chdir - , compileCabalSource chdir - , MaybeT (Just <$> compileSandbox chdir) - ] - - where - run actions = fromJust <$> runMaybeT (msum actions) - - -- | Check if this version is globally available - compileGlobal :: FilePath -> MaybeT IO (Either ExitCode FilePath) - compileGlobal chdir = do - _ <- MaybeT $ find (== cabalVer) <$> listCabalVersions opts - liftIO $ compileWithPkg chdir Nothing - - -- | Check if we already compiled this version of cabal into a private - -- package-db - cachedCabalPkg :: FilePath -> MaybeT IO (Either ExitCode FilePath) - cachedCabalPkg chdir = do - db_exists <- liftIO $ cabalPkgDbExists opts cabalVer - case db_exists of - False -> mzero - True -> liftIO $ do - db <- cabalPkgDb opts cabalVer - compileWithPkg chdir (Just db) - - -- | See if we're in a cabal source tree - compileCabalSource :: FilePath -> MaybeT IO (Either ExitCode FilePath) - compileCabalSource chdir = do - couldBeSrcDir <- liftIO $ takeDirectory <$> getDataDir - let cabalFile = couldBeSrcDir "Cabal.cabal" - cabal <- liftIO $ doesFileExist cabalFile - case cabal of - False -> mzero - True -> liftIO $ do - ver <- cabalFileVersion <$> readFile cabalFile - compileWithCabalTree chdir ver couldBeSrcDir - - -- | Compile the requested cabal version into an isolated package-db - compileSandbox :: FilePath -> IO (Either ExitCode FilePath) - compileSandbox chdir = do - db <- installCabal opts cabalVer `E.catch` - \(SomeException _) -> errorInstallCabal cabalVer - compileWithPkg chdir (Just db) - - compileWithCabalTree chdir ver srcDir = - compile opts $ Compile chdir (Just srcDir) Nothing ver [] - - compileWithPkg chdir mdb = - compile opts $ Compile chdir Nothing mdb cabalVer [cabalPkgId cabalVer] - - cabalPkgId v = "Cabal-" ++ showVersion v - --- errorNoCabal :: Version -> a --- errorNoCabal cabalVer = panic $ printf "\ --- \No appropriate Cabal package found, wanted version %s.\n" --- where --- sver = showVersion cabalVer - -errorInstallCabal :: Version -> a -errorInstallCabal cabalVer = panic $ printf "\ -\Installing Cabal version %s failed.\n\ -\n\ -\You have two choices now:\n\ -\- Either you install this version of Cabal in your globa/luser package-db\n\ -\ somehow\n\ -\n\ -\- Or you can see if you can update your cabal-install to use a different\n\ -\ version of the Cabal library that we can build with:\n\ -\ $ cabal install cabal-install --constraint 'Cabal > %s'\n\ -\n\ -\To check the version cabal-install is currently using try:\n\ -\ $ cabal --version\n" sver sver - where - sver = showVersion cabalVer - -errorNoMain :: FilePath -> a -errorNoMain datadir = panic $ printf "\ -\Could not find $datadir/CabalHelper/Main.hs!\n\ -\\n\ -\If you are a developer you can use the environment variable `ghc_mod_datadir'\n\ -\to override $datadir[1], `$ export ghc_mod_datadir=$PWD' will work in the\n\ -\ghc-mod tree.\n\ -\[1]: %s\n\ -\\n\ -\If you don't know what I'm talking about something went wrong with your\n\ -\installation. Please report this problem here:\n\ -\ https://github.com/kazu-yamamoto/ghc-mod/issues" datadir - -data Compile = Compile { - cabalHelperSourceDir :: FilePath, - cabalSourceDir :: Maybe FilePath, - packageDb :: Maybe FilePath, - cabalVersion :: Version, - packageDeps :: [String] - } - -compile :: Options -> Compile -> IO (Either ExitCode FilePath) -compile Options {..} Compile {..} = do - outdir <- appDataDir - createDirectoryIfMissing True outdir - exe <- exePath cabalVersion - - let Version (mj:mi:_) _ = cabalVersion - let ghc_opts = - concat [ - [ "-outputdir", outdir - , "-o", exe - , "-optP-DCABAL_HELPER=1" - , "-optP-DCABAL_MAJOR=" ++ show mj - , "-optP-DCABAL_MINOR=" ++ show mi - ], - maybeToList $ ("-package-db="++) <$> packageDb, - map ("-i"++) $ cabalHelperSourceDir:maybeToList cabalSourceDir, - concatMap (\p -> ["-package", p]) packageDeps, - [ "--make", cabalHelperSourceDir "CabalHelper/Main.hs" ] - ] - - -- TODO: touch exe after, ghc doesn't do that if the input files didn't - -- actually change - rv <- callProcessStderr' Nothing ghcProgram ghc_opts - return $ case rv of - ExitSuccess -> Right exe - e@(ExitFailure _) -> Left e - -exePath :: Version -> IO FilePath -exePath cabalVersion = do - outdir <- appDataDir - return $ outdir "cabal-helper-" ++ showVersion cabalVersion - -cachedExe :: Version -> FilePath -> IO (Maybe FilePath) -cachedExe cabalVersion chdir = do - exe <- exePath cabalVersion - exists <- doesFileExist exe - case exists of - False -> return Nothing - True -> do - texe <- timeFile exe - tsrcs <- mapM timeFile srcFiles - return $ if any (texe <) tsrcs then Nothing else Just exe - where - srcFiles = - map ((chdir "CabalHelper") ) ["Main.hs", "Common.hs", "Types.hs"] - -callProcessStderr' :: Maybe FilePath -> FilePath -> [String] -> IO ExitCode -callProcessStderr' mwd exe args = do - (_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr - , cwd = mwd } - waitForProcess h - -callProcessStderr :: Maybe FilePath -> FilePath -> [String] -> IO () -callProcessStderr mwd exe args = do - rv <- callProcessStderr' mwd exe args - case rv of - ExitSuccess -> return () - ExitFailure v -> processFailedException "callProcessStderr" exe args v - -processFailedException :: String -> String -> [String] -> Int -> IO a -processFailedException fn exe args rv = - panic $ concat [fn, ": ", exe, " " - , intercalate " " (map show args) - , " (exit " ++ show rv ++ ")"] - -installCabal :: Options -> Version -> IO FilePath -installCabal opts ver = do - appdir <- appDataDir - hPutStr stderr $ printf "\ -\cabal-helper-wrapper: Installing a private copy of Cabal, this might take a\n\ -\while but will only happen once per Cabal version.\n\ -\\n\ -\If anything goes horribly wrong just delete this directory and try again:\n\ -\ %s\n\ -\\n\ -\If you want to avoid this automatic installation altogether install version\n\ -\%s of Cabal manually (into your use or global package-db):\n\ -\ $ cabal install Cabal-%s\n\ -\..." appdir (showVersion ver) (showVersion ver) - - db <- createPkgDb opts ver - callProcessStderr (Just "/") (cabalProgram opts) $ concat - [ - [ "--package-db=clear" - , "--package-db=global" - , "--package-db=" ++ db - , "--prefix=" ++ db "prefix" - , "-v0" - , "--with-ghc=" ++ ghcProgram opts - ] - , if ghcPkgProgram opts /= ghcPkgProgram defaultOptions - then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ] - else [] - , [ "install", "Cabal-"++showVersion ver ] - ] - hPutStrLn stderr "Done" - return db - -ghcVersion :: Options -> IO Version -ghcVersion Options {..} = do - parseVer . trim <$> readProcess ghcProgram ["--numeric-version"] "" - -ghcPkgVersion :: Options -> IO Version -ghcPkgVersion Options {..} = do - parseVer . trim <$> readProcess ghcPkgProgram ["--numeric-version"] "" - -trim :: String -> String -trim = dropWhileEnd isSpace - -createPkgDb :: Options -> Version -> IO FilePath -createPkgDb opts@Options {..} ver = do - db <- cabalPkgDb opts ver - exists <- doesDirectoryExist db - when (not exists) $ callProcessStderr Nothing ghcPkgProgram ["init", db] - return db - -cabalPkgDb :: Options -> Version -> IO FilePath -cabalPkgDb opts ver = do - appdir <- appDataDir - ghcVer <- ghcVersion opts - return $ appdir "Cabal-" ++ showVersion ver ++ "-db-" ++ showVersion ghcVer - -cabalPkgDbExists :: Options -> Version -> IO Bool -cabalPkgDbExists opts ver = do - db <- cabalPkgDb opts ver - dexists <- doesDirectoryExist db - case dexists of - False -> return False - True -> do - vers <- listCabalVersions' opts (Just db) - return $ ver `elem` vers - -listCabalVersions :: Options -> IO [Version] -listCabalVersions opts = listCabalVersions' opts Nothing - --- TODO: Include sandbox? Probably only relevant for build-type:custom projects. -listCabalVersions' :: Options -> Maybe FilePath -> IO [Version] -listCabalVersions' Options {..} mdb = do - let mdbopt = ("--package-db="++) <$> mdb - opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt - - catMaybes . map (fmap snd . parsePkgId . fromString) . words - <$> readProcess ghcPkgProgram opts "" - --- | Find @version: XXX@ delcaration in a cabal file -cabalFileVersion :: String -> Version -cabalFileVersion cabalFile = do - fromJust $ parseVer . extract <$> find ("version" `isPrefixOf`) ls - where - ls = map (map toLower) $ lines cabalFile - extract = dropWhile (/=':') >>> dropWhile isSpace >>> takeWhile (not . isSpace) diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 68d26f9..8264376 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -58,6 +58,7 @@ module Language.Haskell.GhcMod ( import Language.Haskell.GhcMod.Boot import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.CaseSplit +import Language.Haskell.GhcMod.CabalHelper import Language.Haskell.GhcMod.Check import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Debug @@ -72,3 +73,4 @@ import Language.Haskell.GhcMod.Modules import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Target diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index f674157..53a8e8f 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -15,21 +15,18 @@ -- along with this program. If not, see . module Language.Haskell.GhcMod.CabalHelper ( - CabalHelper(..) - , getComponents - , getGhcOptions + getComponents , getGhcPkgOptions - , cabalHelper ) where import Control.Applicative -import Control.Arrow import Control.Monad import Data.Monoid -import Data.List -import Language.Haskell.GhcMod.Types +import Distribution.Helper +import qualified Language.Haskell.GhcMod.Types as T +import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram, + cabalProgram) import Language.Haskell.GhcMod.Monad.Types -import Language.Haskell.GhcMod.Error as E import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World import Language.Haskell.GhcMod.PathsAndFiles @@ -37,26 +34,42 @@ import System.FilePath -- | Only package related GHC options, sufficient for things that don't need to -- access home modules -getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])] -getGhcPkgOptions = chGhcPkgOptions `liftM` cabalHelper +getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(ChComponentName, [GHCOption])] +getGhcPkgOptions = do + Cradle {..} <- cradle + let distdir = cradleRootDir "dist" + runQuery distdir ghcPkgOptions -getGhcOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])] -getGhcOptions = chGhcOptions `liftM` cabalHelper +helperProgs :: Options -> Programs +helperProgs opts = Programs { + cabalProgram = T.cabalProgram opts, + ghcProgram = T.ghcProgram opts, + ghcPkgProgram = T.ghcPkgProgram opts + } -- | Primary interface to cabal-helper and intended single entrypoint to -- constructing 'GmComponent's -- -- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by -- 'resolveGmComponents'. -getComponents :: (MonadIO m, GmEnv m) - => m [GmComponent (Either FilePath [ModuleName])] -getComponents = cabalHelper >>= \CabalHelper {..} -> return $ let - ([(scn, sep)], eps) = partition ((GmSetupHsName ==) . fst) chEntrypoints - sc = GmComponent scn [] [] sep sep ["."] mempty - cs = flip map (zip4 eps chGhcOptions chGhcSrcOptions chSourceDirs) $ - \((cn, ep), (_, opts), (_, srcOpts), (_, srcDirs)) -> +getComponents :: (MonadIO m, GmEnv m) => m [GmComponent ChEntrypoint] +getComponents = withCabal $ do + Cradle {..} <- cradle + let distdir = cradleRootDir "dist" + opt <- options + + runQuery' (helperProgs opt) distdir $ do + q <- liftM4 join4 ghcOptions ghcSrcOptions entrypoints sourceDirs + return $ flip map q $ \(cn, (opts, (srcOpts, (ep, srcDirs)))) -> GmComponent cn opts srcOpts ep ep srcDirs mempty - in sc:cs + where + join4 a b c = join' a . join' b . join' c + join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))] + join' lb lc = [ (a, (b, c)) + | (a, b) <- lb + , (a', c) <- lc + , a == a' + ] withCabal :: (MonadIO m, GmEnv m) => m a -> m a withCabal action = do @@ -65,58 +78,11 @@ withCabal action = do liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $ withDirectory_ (cradleRootDir crdl) $ do let progOpts = - [ "--with-ghc=" ++ ghcProgram opts ] + [ "--with-ghc=" ++ T.ghcProgram opts ] -- Only pass ghc-pkg if it was actually set otherwise we -- might break cabal's guessing logic - ++ if ghcPkgProgram opts /= ghcPkgProgram defaultOptions - then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ] + ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions + then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ] else [] - void $ readProcess (cabalProgram opts) ("configure":progOpts) "" + void $ readProcess (T.cabalProgram opts) ("configure":progOpts) "" action - -data CabalHelper = CabalHelper { - chEntrypoints :: [(GmComponentName, Either FilePath [ModuleName])], - chSourceDirs :: [(GmComponentName, [String])], - chGhcOptions :: [(GmComponentName, [String])], - chGhcSrcOptions :: [(GmComponentName, [String])], - chGhcPkgOptions :: [(GmComponentName, [String])] - } deriving (Show) - -cabalHelper :: (MonadIO m, GmEnv m) => m CabalHelper -cabalHelper = withCabal $ do - Cradle {..} <- cradle - Options {..} <- options - let progArgs = [ "--with-ghc=" ++ ghcProgram - , "--with-ghc-pkg=" ++ ghcPkgProgram - , "--with-cabal=" ++ cabalProgram - ] - - let args = [ "entrypoints" - , "source-dirs" - , "ghc-options" - , "ghc-src-options" - , "ghc-pkg-options" - ] ++ progArgs - - distdir = cradleRootDir "dist" - - res <- liftIO $ do - exe <- findLibexecExe "cabal-helper-wrapper" - hexe <- readProcess exe ([distdir, "print-exe"] ++ progArgs) "" - - cached cradleRootDir (cabalHelperCache hexe args) $ do - out <- readProcess exe (distdir:args) "" - evaluate (read out) `E.catch` - \(SomeException _) -> error "cabalHelper: read failed" - - let [ Just (GmCabalHelperEntrypoints eps), - Just (GmCabalHelperStrings srcDirs), - Just (GmCabalHelperStrings ghcOpts), - Just (GmCabalHelperStrings ghcSrcOpts), - Just (GmCabalHelperStrings ghcPkgOpts) ] = res - eps' = map (second $ fmap $ map md) eps - - return $ CabalHelper eps' srcDirs ghcOpts ghcSrcOpts ghcPkgOpts - - where - md (GmModuleName mn) = mkModuleName mn diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 9d7f979..8de1a8d 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -103,6 +103,7 @@ import Data.Map (Map, empty) import Data.Maybe import Data.Monoid import Data.IORef +import Distribution.Helper import MonadUtils (MonadIO(..)) @@ -128,7 +129,7 @@ data GmGhcSession = GmGhcSession { data GhcModState = GhcModState { gmGhcSession :: !(Maybe GmGhcSession) - , gmComponents :: !(Map GmComponentName (GmComponent (Set ModulePath))) + , gmComponents :: !(Map ChComponentName (GmComponent (Set ModulePath))) , gmCompilerMode :: !CompilerMode } diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index efbb98f..ac41f71 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -23,7 +23,9 @@ import Control.Monad.Trans.Maybe import Data.List import Data.Char import Data.Maybe +import Data.Version import Data.Traversable (traverse) +import Distribution.Helper import System.Directory import System.FilePath import System.IO.Unsafe @@ -233,11 +235,11 @@ cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $ packageCache :: String packageCache = "package.cache" -cabalHelperCache :: - FilePath -> [String] -> Cached [String] [Maybe GmCabalHelperResponse] -cabalHelperCache cabalHelperExe cmds = Cached { - inputFiles = [cabalHelperExe, setupConfigPath], - inputData = cmds, +cabalHelperCache :: Version -> [String] + -> Cached (Version, [String]) [GmComponent ChEntrypoint] +cabalHelperCache cabalHelperVer cmds = Cached { + inputFiles = [setupConfigPath], + inputData = (cabalHelperVer, cmds), cacheFile = setupConfigPath <.> "ghc-mod.cabal-helper" } diff --git a/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs index a6a8e0e..57e39a8 100644 --- a/Language/Haskell/GhcMod/Pretty.hs +++ b/Language/Haskell/GhcMod/Pretty.hs @@ -19,6 +19,7 @@ module Language.Haskell.GhcMod.Pretty where import Control.Arrow hiding ((<+>)) import Data.Char import Data.List +import Distribution.Helper import Text.PrettyPrint import Language.Haskell.GhcMod.Types @@ -29,12 +30,12 @@ docStyle = style { ribbonsPerLine = 1.2 } gmRenderDoc :: Doc -> String gmRenderDoc = renderStyle docStyle -gmComponentNameDoc :: GmComponentName -> Doc -gmComponentNameDoc GmSetupHsName = text $ "Setup.hs" -gmComponentNameDoc GmLibName = text $ "library" -gmComponentNameDoc (GmExeName n) = text $ "exe:" ++ n -gmComponentNameDoc (GmTestName n) = text $ "test:" ++ n -gmComponentNameDoc (GmBenchName n) = text $ "bench:" ++ n +gmComponentNameDoc :: ChComponentName -> Doc +gmComponentNameDoc ChSetupHsName = text $ "Setup.hs" +gmComponentNameDoc ChLibName = text $ "library" +gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n +gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n +gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n gmLogLevelDoc :: GmLogLevel -> Doc gmLogLevelDoc GmPanic = text "PANIC" diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 994c687..498b41b 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -46,6 +46,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set +import Distribution.Helper import System.Directory import System.FilePath @@ -185,9 +186,9 @@ targetGhcOptions crdl sefnmn = do let cn = pickComponent candidates return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs -moduleComponents :: Map GmComponentName (GmComponent (Set ModulePath)) +moduleComponents :: Map ChComponentName (GmComponent (Set ModulePath)) -> Either FilePath ModuleName - -> Set GmComponentName + -> Set ChComponentName moduleComponents m efnmn = foldr' Set.empty m $ \c s -> let @@ -203,10 +204,9 @@ moduleComponents m efnmn = foldr' b as f = Map.foldr f b as -pickComponent :: Set GmComponentName -> GmComponentName +pickComponent :: Set ChComponentName -> ChComponentName pickComponent scn = Set.findMin scn - packageGhcOptions :: (MonadIO m, GmEnv m) => m [GHCOption] packageGhcOptions = do crdl <- cradle @@ -223,14 +223,16 @@ sandboxOpts crdl = return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts resolveGmComponent :: (IOish m, GmLog m, GmEnv m) => Maybe [Either FilePath ModuleName] -- ^ Updated modules - -> GmComponent (Either FilePath [ModuleName]) + -> GmComponent ChEntrypoint -> m (GmComponent (Set ModulePath)) resolveGmComponent mums c@GmComponent {..} = withLightHscEnv gmcGhcSrcOpts $ \env -> do let srcDirs = gmcSourceDirs mg = gmcHomeModuleGraph - let eps = either (return . Left) (map Right) gmcEntrypoints + Cradle { cradleRootDir } <- cradle + + eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints simp <- liftIO $ resolveEntrypoints env srcDirs eps sump <- liftIO $ case mums of Nothing -> return simp @@ -263,11 +265,30 @@ resolveEntrypoints env srcDirs ms = findFile' dirs file = mconcat <$> mapM (mightExist . (file)) dirs +resolveChEntrypoints :: + FilePath -> ChEntrypoint -> IO [Either FilePath ModuleName] +resolveChEntrypoints _ (ChLibEntrypoint em om) = + return $ map (Right . chModToMod) (em ++ om) + +resolveChEntrypoints _ (ChExeEntrypoint main om) = + return $ [Left main] ++ map (Right . chModToMod) om + +resolveChEntrypoints srcDir ChSetupEntrypoint = do + shs <- doesFileExist (srcDir "Setup.hs") + slhs <- doesFileExist (srcDir "Setup.lhs") + return $ case (shs, slhs) of + (True, _) -> [Left "Setup.hs"] + (_, True) -> [Left "Setup.lhs"] + (False, False) -> [] + +chModToMod :: ChModuleName -> ModuleName +chModToMod (ChModuleName mn) = mkModuleName mn + resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m) => Maybe [Either FilePath ModuleName] -- ^ Updated modules - -> [GmComponent (Either FilePath [ModuleName])] - -> m (Map GmComponentName (GmComponent (Set ModulePath))) + -> [GmComponent ChEntrypoint] + -> m (Map ChComponentName (GmComponent (Set ModulePath))) resolveGmComponents mumns cs = do s <- gmsGet m' <- foldrM' (gmComponents s) cs $ \c m -> do diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 352b658..5e43d80 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -2,7 +2,6 @@ {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} module Language.Haskell.GhcMod.Types ( module Language.Haskell.GhcMod.Types - , module CabalHelper.Types , ModuleName , mkModuleName , moduleNameString @@ -18,13 +17,12 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Monoid import Data.Typeable (Typeable) +import Distribution.Helper import Exception (ExceptionMonad) import MonadUtils (MonadIO) import GHC (ModuleName, moduleNameString, mkModuleName) import PackageConfig (PackageConfig) -import CabalHelper.Types - -- | A constraint alias (-XConstraintKinds) to make functions dealing with -- 'GhcModT' somewhat cleaner. -- @@ -168,10 +166,10 @@ instance Monoid GmModuleGraph where GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c') data GmComponent eps = GmComponent { - gmcName :: GmComponentName, + gmcName :: ChComponentName, gmcGhcOpts :: [GHCOption], gmcGhcSrcOpts :: [GHCOption], - gmcRawEntrypoints :: Either FilePath [ModuleName], + gmcRawEntrypoints :: ChEntrypoint, gmcEntrypoints :: eps, gmcSourceDirs :: [FilePath], gmcHomeModuleGraph :: GmModuleGraph @@ -204,10 +202,10 @@ data GhcModError | GMECabalFlags GhcModError -- ^ Retrieval of the cabal configuration flags failed. - | GMECabalComponent GmComponentName + | GMECabalComponent ChComponentName -- ^ Cabal component could not be found - | GMECabalCompAssignment [(Either FilePath ModuleName, Set GmComponentName)] + | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)] -- ^ Could not find a consistent component assignment for modules | GMEProcess String [String] (Either (String, String, Int) GhcModError) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 2d7221e..8f51037 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -24,7 +24,6 @@ Cabal-Version: >= 1.16 Build-Type: Custom Data-Files: elisp/Makefile elisp/*.el - CabalHelper/*.hs Extra-Source-Files: ChangeLog SetupCompat.hs @@ -78,7 +77,6 @@ Library Language.Haskell.GhcMod.Internal Other-Modules: Paths_ghc_mod Utils - CabalHelper.Types Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Browse Language.Haskell.GhcMod.CaseSplit @@ -116,6 +114,7 @@ Library Build-Depends: base >= 4.0 && < 5 , bytestring , containers + , cabal-helper >= 0.3 , deepseq , directory , filepath @@ -186,27 +185,6 @@ Executable ghc-modi , ghc , ghc-mod -Executable cabal-helper-wrapper - Default-Language: Haskell2010 - Other-Extensions: TemplateHaskell - Main-Is: CabalHelper/Wrapper.hs - Other-Modules: Paths_ghc_mod - GHC-Options: -Wall - HS-Source-Dirs: . - X-Install-Target: $libexecdir - Build-Depends: base >= 4.0 && < 5 - , bytestring - , binary - , containers - , Cabal >= 1.14 - , directory - , filepath - , old-time - , process - , transformers - , template-haskell - , time - Test-Suite doctest Type: exitcode-stdio-1.0 Default-Language: Haskell2010 From 7019cbcfa1e16df1e0a9b8312cd3a7df29d2924e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 28 Mar 2015 02:30:51 +0100 Subject: [PATCH 051/207] Implement better caching for target options --- Language/Haskell/GhcMod/CabalHelper.hs | 34 ++++-- Language/Haskell/GhcMod/Caching.hs | 83 +++++++++++++++ Language/Haskell/GhcMod/Monad/Types.hs | 2 +- Language/Haskell/GhcMod/PathsAndFiles.hs | 67 ++---------- Language/Haskell/GhcMod/Target.hs | 127 +++++++++++++++-------- Language/Haskell/GhcMod/Types.hs | 61 ++++++++++- Utils.hs | 7 +- 7 files changed, 261 insertions(+), 120 deletions(-) create mode 100644 Language/Haskell/GhcMod/Caching.hs diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 53a8e8f..74ad106 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -22,6 +22,7 @@ module Language.Haskell.GhcMod.CabalHelper ( import Control.Applicative import Control.Monad import Data.Monoid +import Data.Version import Distribution.Helper import qualified Language.Haskell.GhcMod.Types as T import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram, @@ -52,16 +53,31 @@ helperProgs opts = Programs { -- -- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by -- 'resolveGmComponents'. -getComponents :: (MonadIO m, GmEnv m) => m [GmComponent ChEntrypoint] -getComponents = withCabal $ do - Cradle {..} <- cradle - let distdir = cradleRootDir "dist" - opt <- options +getComponents :: (MonadIO m, GmEnv m, GmLog m) + => m [GmComponent GMCRaw ChEntrypoint] +getComponents = do + opt <- options + Cradle {..} <- cradle + let gmVer = GhcMod.version + chVer = VERSION_cabal_helper + d = (helperProgs opt + , cradleRootDir "dist" + , (gmVer, chVer) + ) + withCabal $ cached cradleRootDir cabalHelperCache d - runQuery' (helperProgs opt) distdir $ do - q <- liftM4 join4 ghcOptions ghcSrcOptions entrypoints sourceDirs - return $ flip map q $ \(cn, (opts, (srcOpts, (ep, srcDirs)))) -> - GmComponent cn opts srcOpts ep ep srcDirs mempty +cabalHelperCache :: MonadIO m => Cached m + (Programs, FilePath, (Version, String)) + [GmComponent GMCRaw ChEntrypoint] +cabalHelperCache = Cached { + cacheFile = cabalHelperCacheFile, + cachedAction = \ _ (progs, root, _) -> + runQuery' progs root $ do + q <- liftM4 join4 ghcOptions ghcSrcOptions entrypoints sourceDirs + let cs = flip map q $ \(cn, (opts, (srcOpts, (ep, srcDirs)))) -> + GmComponent cn opts srcOpts ep ep srcDirs mempty + return ([setupConfigPath], cs) + } where join4 a b c = join' a . join' b . join' c join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))] diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs new file mode 100644 index 0000000..db07af4 --- /dev/null +++ b/Language/Haskell/GhcMod/Caching.hs @@ -0,0 +1,83 @@ +module Language.Haskell.GhcMod.Caching where + +import Control.Monad.Trans.Maybe +import Data.Maybe +import Data.Serialize +import qualified Data.ByteString as BS +import System.FilePath + +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Logging + +import Utils + +data Cached m d a = + Cached { cacheFile :: FilePath, + cachedAction :: TimedCacheFiles -> d -> m ([FilePath], a) + -- ^ The cached action, will only run if + -- * The cache doesn\'t exist yet + -- * The cache exists and 'inputData' changed + -- * any files in 'inputFiles' are older than 'cacheFile'. + } + +data TimedCacheFiles = + TimedCacheFiles { tcCacheFile :: Maybe TimedFile, + tcFiles :: [TimedFile] + } + +-- | Cache a MonadIO action with proper invalidation. +cached :: forall m a d. (MonadIO m, GmLog m, Serialize a, Eq d, Serialize d) + => FilePath -- ^ Directory to prepend to 'cacheFile' + -> Cached m d a -- ^ Cache descriptor + -> d + -> m a +cached dir cd d = do + mcc <- readCache + tcfile <- liftIO $ timeMaybe (cacheFile cd) + let defTcf = TimedCacheFiles tcfile [] + + case mcc of + Nothing -> writeCache defTcf "cache missing" + Just (ifs, d', _) | d /= d' -> do + tcf <- timeCacheInput dir (cacheFile cd) ifs + writeCache tcf "input data changed" + Just (ifs, _, a) -> do + tcf <- timeCacheInput dir (cacheFile cd) ifs + let invifs = invalidatingInputFiles tcf + case invifs of + Nothing -> writeCache tcf "cache missing, existed a sec ago WTF?" + Just [] -> return a + Just _ -> writeCache tcf "input files changed" + + where + writeCache tcf cause = do + (ifs', a) <- (cachedAction cd) tcf d + gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) + <+> parens (text cause) + liftIO $ BS.writeFile (dir cacheFile cd) $ encode (ifs', d, a) + return a + + readCache :: m (Maybe ([FilePath], d, a)) + readCache = runMaybeT $ do + f <- MaybeT $ liftIO $ mightExist $ cacheFile cd + MaybeT $ readCache' f + where + readCache' f = do + gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd) + cc <- liftIO $ BS.readFile f + return $ either (const Nothing) Just $ decode cc + +timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles +timeCacheInput dir cfile ifs = liftIO $ do + -- TODO: is checking the times this way around race free? + ins <- (timeMaybe . (dir )) `mapM` ifs + mtcfile <- timeMaybe cfile + return $ TimedCacheFiles mtcfile (catMaybes ins) + +invalidatingInputFiles :: TimedCacheFiles -> Maybe [FilePath] +invalidatingInputFiles tcf = + case tcCacheFile tcf of + Nothing -> Nothing + Just tcfile -> Just $ map tfPath $ + -- get input files older than tcfile + filter (tcfile<) $ tcFiles tcf diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 8de1a8d..b6ee787 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -129,7 +129,7 @@ data GmGhcSession = GmGhcSession { data GhcModState = GhcModState { gmGhcSession :: !(Maybe GmGhcSession) - , gmComponents :: !(Map ChComponentName (GmComponent (Set ModulePath))) + , gmComponents :: !(Map ChComponentName (GmComponent GMCResolved (Set ModulePath))) , gmCompilerMode :: !CompilerMode } diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index ac41f71..b1dcda3 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -14,27 +14,26 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -module Language.Haskell.GhcMod.PathsAndFiles where +module Language.Haskell.GhcMod.PathsAndFiles ( + module Language.Haskell.GhcMod.PathsAndFiles + , module Language.Haskell.GhcMod.Caching + ) where import Config (cProjectVersion) import Control.Applicative import Control.Monad -import Control.Monad.Trans.Maybe import Data.List import Data.Char import Data.Maybe -import Data.Version import Data.Traversable (traverse) -import Distribution.Helper import System.Directory import System.FilePath import System.IO.Unsafe import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.Read import Language.Haskell.GhcMod.Utils hiding (dropWhileEnd) +import Language.Haskell.GhcMod.Caching import qualified Language.Haskell.GhcMod.Utils as U -- | Guaranteed to be a path to a directory with no trailing slash. @@ -43,12 +42,6 @@ type DirPath = FilePath -- | Guaranteed to be the name of a file only (no slashes). type FileName = String -data Cached d a = Cached { - inputFiles :: [FilePath], - inputData :: d, - cacheFile :: FilePath - } - newtype UnString = UnString { unString :: String } instance Show UnString where @@ -57,43 +50,6 @@ instance Show UnString where instance Read UnString where readsPrec _ = \str -> [(UnString str, "")] --- | --- --- >>> any (Just 3 <) [Just 1, Nothing, Just 2] --- False --- --- >>> any (Just 0 <) [Just 1, Nothing, Just 2] --- True --- --- >>> any (Just 0 <) [Nothing] --- False --- --- >>> any (Just 0 <) [] --- False -cached :: forall a d. (Read a, Show a, Eq d, Read d, Show d) - => DirPath -> Cached d a -> IO a -> IO a -cached dir Cached {..} ma = do - ins <- (maybeTimeFile . (dir )) `mapM` inputFiles - c <- maybeTimeFile (dir cacheFile) - if any (c<) ins || isNothing c - then writeCache - else maybe ma return =<< readCache - where - maybeTimeFile :: FilePath -> IO (Maybe TimedFile) - maybeTimeFile f = traverse timeFile =<< mightExist f - - writeCache = do - a <- ma - writeFile (dir cacheFile) $ unlines [show inputData, show a] - return a - - readCache :: IO (Maybe a) - readCache = runMaybeT $ do - hdr:c:_ <- lines <$> liftIO (readFile $ dir cacheFile) - if inputData /= read hdr - then liftIO $ writeCache - else MaybeT $ return $ readMaybe c - -- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent -- directories. The first parent directory containing more than one cabal file -- is assumed to be the project directory. If only one cabal file exists in this @@ -235,13 +191,6 @@ cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $ packageCache :: String packageCache = "package.cache" -cabalHelperCache :: Version -> [String] - -> Cached (Version, [String]) [GmComponent ChEntrypoint] -cabalHelperCache cabalHelperVer cmds = Cached { - inputFiles = [setupConfigPath], - inputData = (cabalHelperVer, cmds), - cacheFile = setupConfigPath <.> "ghc-mod.cabal-helper" - } -- | Filename of the symbol table cache file. symbolCache :: Cradle -> FilePath @@ -249,3 +198,9 @@ symbolCache crdl = cradleTempDir crdl symbolCacheFile symbolCacheFile :: String symbolCacheFile = "ghc-mod.symbol-cache" + +resolvedComponentsCacheFile :: String +resolvedComponentsCacheFile = setupConfigPath <.> "ghc-mod.resolved-components" + +cabalHelperCacheFile :: String +cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-helper" diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 498b41b..3a7c78d 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -32,6 +32,7 @@ import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.CabalHelper import Language.Haskell.GhcMod.HomeModuleGraph +import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logging @@ -154,7 +155,7 @@ runGmlTWith efnmns' mdf wrapper action = do loadTargets (map moduleNameString mns ++ rfns) action -targetGhcOptions :: IOish m +targetGhcOptions :: forall m. IOish m => Cradle -> Set (Either FilePath ModuleName) -> GhcModT m [GHCOption] @@ -162,12 +163,15 @@ targetGhcOptions crdl sefnmn = do when (Set.null sefnmn) $ error "targetGhcOptions: no targets given" case cradleCabalFile crdl of - Just _ -> cabalOpts + Just _ -> cabalOpts crdl Nothing -> sandboxOpts crdl where zipMap f l = l `zip` (f `map` l) - cabalOpts = do - mcs <- resolveGmComponents Nothing =<< getComponents + + cabalOpts :: Cradle -> GhcModT m [String] + cabalOpts Cradle{..} = do + comps <- mapM (resolveEntrypoint crdl) =<< getComponents + mcs <- cached cradleRootDir resolvedComponentsCache comps let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn candidates = Set.unions $ map snd mdlcs @@ -186,7 +190,36 @@ targetGhcOptions crdl sefnmn = do let cn = pickComponent candidates return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs -moduleComponents :: Map ChComponentName (GmComponent (Set ModulePath)) +resolvedComponentsCache :: IOish m => Cached (GhcModT m) + [GmComponent GMCRaw(Set.Set ModulePath)] + (Map.Map ChComponentName (GmComponent GMCResolved (Set.Set ModulePath))) +resolvedComponentsCache = Cached { + cacheFile = resolvedComponentsCacheFile, + cachedAction = \tcfs comps -> do + Cradle {..} <- cradle + let changedFiles = + filter (/= cradleRootDir setupConfigPath) $ map tfPath $ tcFiles tcfs + mums = if null changedFiles + then Nothing + else Just $ map Left changedFiles + + mcs <- resolveGmComponents mums comps + return (setupConfigPath:flatten mcs , mcs) + } + + where + flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath)) + -> [FilePath] + flatten = Map.elems + >>> map (gmcHomeModuleGraph >>> gmgGraph + >>> Map.elems + >>> map (Set.map mpPath) + >>> Set.unions + ) + >>> Set.unions + >>> Set.toList + +moduleComponents :: Map ChComponentName (GmComponent t (Set ModulePath)) -> Either FilePath ModuleName -> Set ChComponentName moduleComponents m efnmn = @@ -216,52 +249,57 @@ packageGhcOptions = do Nothing -> sandboxOpts crdl sandboxOpts :: Monad m => Cradle -> m [String] -sandboxOpts crdl = return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts +sandboxOpts crdl = + return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"] where pkgOpts = ghcDbStackOpts $ cradlePkgDbStack crdl (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl) resolveGmComponent :: (IOish m, GmLog m, GmEnv m) => Maybe [Either FilePath ModuleName] -- ^ Updated modules - -> GmComponent ChEntrypoint - -> m (GmComponent (Set ModulePath)) -resolveGmComponent mums c@GmComponent {..} = + -> GmComponent GMCRaw (Set ModulePath) + -> m (GmComponent GMCResolved (Set ModulePath)) +resolveGmComponent mums c@GmComponent {..} = do withLightHscEnv gmcGhcSrcOpts $ \env -> do - let srcDirs = gmcSourceDirs - mg = gmcHomeModuleGraph - - Cradle { cradleRootDir } <- cradle - - eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints - simp <- liftIO $ resolveEntrypoints env srcDirs eps - sump <- liftIO $ case mums of + let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs + let mg = gmcHomeModuleGraph + let simp = gmcEntrypoints + sump <- case mums of Nothing -> return simp - Just ums -> resolveEntrypoints env srcDirs ums + Just ums -> Set.fromList . catMaybes <$> mapM (resolveModule env srcDirs) ums mg' <- updateHomeModuleGraph env mg simp sump return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' } -resolveEntrypoints :: MonadIO m - => HscEnv -> [FilePath] -> [Either FilePath ModuleName] -> m (Set ModulePath) -resolveEntrypoints env srcDirs ms = - liftIO $ Set.fromList . catMaybes <$> resolve `mapM` ms +resolveEntrypoint :: IOish m + => Cradle + -> GmComponent GMCRaw ChEntrypoint + -> m (GmComponent GMCRaw (Set ModulePath)) +resolveEntrypoint Cradle {..} c@GmComponent {..} = + withLightHscEnv gmcGhcSrcOpts $ \env -> do + let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs + eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints + rms <- resolveModule env srcDirs `mapM` eps + return c { gmcEntrypoints = Set.fromList $ catMaybes rms } + +resolveModule :: MonadIO m => + HscEnv -> [FilePath] -> Either FilePath ModuleName -> m (Maybe ModulePath) +resolveModule env _srcDirs (Right mn) = liftIO $ findModulePath env mn +resolveModule env srcDirs (Left fn') = liftIO $ do + mfn <- findFile' srcDirs fn' + case mfn of + Nothing -> return Nothing + Just fn'' -> do + let fn = normalise fn'' + emn <- fileModuleName env fn + return $ case emn of + Left _ -> Nothing + Right mmn -> Just $ + case mmn of + Nothing -> mkMainModulePath fn + Just mn -> ModulePath mn fn where - resolve :: Either FilePath ModuleName -> IO (Maybe ModulePath) - resolve (Right mn) = findModulePath env mn - resolve (Left fn') = do - mfn <- findFile' srcDirs fn' - case mfn of - Nothing -> return Nothing - Just fn'' -> do - let fn = normalise fn'' - emn <- fileModuleName env fn - return $ case emn of - Left _ -> Nothing - Right mmn -> Just $ - case mmn of - Nothing -> mkMainModulePath fn - Just mn -> ModulePath mn fn findFile' dirs file = mconcat <$> mapM (mightExist . (file)) dirs @@ -284,11 +322,11 @@ resolveChEntrypoints srcDir ChSetupEntrypoint = do chModToMod :: ChModuleName -> ModuleName chModToMod (ChModuleName mn) = mkModuleName mn -resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m) - => Maybe [Either FilePath ModuleName] - -- ^ Updated modules - -> [GmComponent ChEntrypoint] - -> m (Map ChComponentName (GmComponent (Set ModulePath))) +resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m) => + Maybe [Either FilePath ModuleName] + -- ^ Updated modules + -> [GmComponent GMCRaw (Set ModulePath)] + -> m (Map ChComponentName (GmComponent GMCResolved (Set ModulePath))) resolveGmComponents mumns cs = do s <- gmsGet m' <- foldrM' (gmComponents s) cs $ \c m -> do @@ -307,11 +345,10 @@ resolveGmComponents mumns cs = do return $ Map.insert (gmcName rc) rc m same :: Eq b - => (forall a. GmComponent a -> b) - -> GmComponent c -> GmComponent d -> Bool + => (forall t a. GmComponent t a -> b) + -> GmComponent u c -> GmComponent v d -> Bool same f a b = (f a) == (f b) - -- | Set the files as targets and load them. loadTargets :: IOish m => [String] -> GmlT m () loadTargets filesOrModules = do diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 5e43d80..dd2370d 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, GADTs, StandaloneDeriving, DataKinds #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric, StandaloneDeriving, + DefaultSignatures #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} module Language.Haskell.GhcMod.Types ( module Language.Haskell.GhcMod.Types @@ -10,18 +11,24 @@ module Language.Haskell.GhcMod.Types ( import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Error (Error(..)) import Control.Exception (Exception) +import Control.Applicative +import Control.Arrow +import Data.Serialize +import Data.Version import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Data.Monoid +import Data.Maybe import Data.Typeable (Typeable) import Distribution.Helper import Exception (ExceptionMonad) import MonadUtils (MonadIO) import GHC (ModuleName, moduleNameString, mkModuleName) import PackageConfig (PackageConfig) +import GHC.Generics -- | A constraint alias (-XConstraintKinds) to make functions dealing with -- 'GhcModT' somewhat cleaner. @@ -158,14 +165,42 @@ data GmModuleGraph = GmModuleGraph { gmgFileMap :: Map FilePath ModulePath, gmgModuleMap :: Map ModuleName ModulePath, gmgGraph :: Map ModulePath (Set ModulePath) - } deriving (Eq, Ord, Show, Read, Typeable) + } deriving (Eq, Ord, Show, Read, Generic, Typeable) + +instance Serialize GmModuleGraph where + put GmModuleGraph {..} = let + mpim :: Map ModulePath Integer + graph :: Map Integer (Set Integer) + + mpim = Map.fromList $ + (Map.keys gmgGraph) `zip` [0..] + mpToInt :: ModulePath -> Integer + mpToInt mp = fromJust $ Map.lookup mp mpim + + graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph + in put (mpim, graph) + + get = do + (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get + let + swapMap = Map.fromList . map swap . Map.toList + swap (a,b) = (b,a) + impm = swapMap mpim + intToMp i = fromJust $ Map.lookup i impm + mpGraph :: Map ModulePath (Set ModulePath) + mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph + mpFm = Map.fromList $ map (mpPath &&& id) $ Map.keys mpim + mpMn = Map.fromList $ map (mpModule &&& id) $ Map.keys mpim + return $ GmModuleGraph mpFm mpMn mpGraph instance Monoid GmModuleGraph where mempty = GmModuleGraph mempty mempty mempty mappend (GmModuleGraph a b c) (GmModuleGraph a' b' c') = GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c') -data GmComponent eps = GmComponent { +data GmComponentType = GMCRaw + | GMCResolved +data GmComponent (t :: GmComponentType) eps = GmComponent { gmcName :: ChComponentName, gmcGhcOpts :: [GHCOption], gmcGhcSrcOpts :: [GHCOption], @@ -173,10 +208,17 @@ data GmComponent eps = GmComponent { gmcEntrypoints :: eps, gmcSourceDirs :: [FilePath], gmcHomeModuleGraph :: GmModuleGraph - } deriving (Eq, Ord, Show, Read, Typeable) + } deriving (Eq, Ord, Show, Read, Generic, Typeable, Functor) + +instance Serialize eps => Serialize (GmComponent t eps) data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath } - deriving (Eq, Ord, Show, Read, Typeable) + deriving (Eq, Ord, Show, Read, Generic, Typeable) +instance Serialize ModulePath + +instance Serialize ModuleName where + get = mkModuleName <$> get + put mn = put (moduleNameString mn) instance Show ModuleName where show mn = "ModuleName " ++ show (moduleNameString mn) @@ -235,3 +277,12 @@ data GMConfigStateFileError | GMConfigStateFileMissing -- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) deriving (Eq, Show, Read, Typeable) + + +deriving instance Generic Version +instance Serialize Version + +instance Serialize Programs +instance Serialize ChModuleName +instance Serialize ChComponentName +instance Serialize ChEntrypoint diff --git a/Utils.hs b/Utils.hs index 8c1d057..7bfd18e 100644 --- a/Utils.hs +++ b/Utils.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module Utils where -import Control.Monad import Control.Applicative import Data.Traversable import System.Directory @@ -18,7 +17,8 @@ type ModTime = UTCTime type ModTime = ClockTime #endif -data TimedFile = TimedFile FilePath ModTime deriving (Eq, Show) +data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime } + deriving (Eq, Show) instance Ord TimedFile where compare (TimedFile _ a) (TimedFile _ b) = compare a b @@ -32,5 +32,4 @@ mightExist f = do return $ if exists then (Just f) else (Nothing) timeMaybe :: FilePath -> IO (Maybe TimedFile) -timeMaybe f = do - join $ (timeFile `traverse`) <$> mightExist f +timeMaybe f = traverse timeFile =<< mightExist f From 2a02742f9e0a6b9976ba07439566f4cfb8b2bc33 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 28 Mar 2015 02:31:29 +0100 Subject: [PATCH 052/207] Write autogen file when calling `cabal configure` --- Language/Haskell/GhcMod/CabalHelper.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 74ad106..b1a716b 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -101,4 +101,5 @@ withCabal action = do then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ] else [] void $ readProcess (T.cabalProgram opts) ("configure":progOpts) "" + writeAutogenFiles $ cradleRootDir crdl "dist" action From 80d91776c5601088d28fd08f0ee6ade36f4ef636 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 28 Mar 2015 02:33:42 +0100 Subject: [PATCH 053/207] Cleanup and some fixes --- Language/Haskell/GhcMod.hs | 3 +- Language/Haskell/GhcMod/CabalHelper.hs | 4 ++ Language/Haskell/GhcMod/Debug.hs | 21 +++++- Language/Haskell/GhcMod/HomeModuleGraph.hs | 2 +- Language/Haskell/GhcMod/Logging.hs | 17 ++++- Language/Haskell/GhcMod/Monad/Types.hs | 6 +- ghc-mod.cabal | 10 ++- src/GHCMod.hs | 7 +- test/CabalHelperSpec.hs | 66 +++++++++---------- test/Main.hs | 6 +- .../check-test-subdir/check-test-subdir.cabal | 1 + .../pattern-synonyms/pattern-synonyms.cabal | 3 +- 12 files changed, 94 insertions(+), 52 deletions(-) diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 8264376..0b358a6 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -34,6 +34,7 @@ module Language.Haskell.GhcMod ( , check , checkSyntax , debugInfo + , componentInfo , expandTemplate , info , lint @@ -58,7 +59,6 @@ module Language.Haskell.GhcMod ( import Language.Haskell.GhcMod.Boot import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.CaseSplit -import Language.Haskell.GhcMod.CabalHelper import Language.Haskell.GhcMod.Check import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Debug @@ -73,4 +73,3 @@ import Language.Haskell.GhcMod.Modules import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Target diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index b1a716b..85b90d0 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -14,6 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.CabalHelper ( getComponents , getGhcPkgOptions @@ -33,6 +34,8 @@ import Language.Haskell.GhcMod.World import Language.Haskell.GhcMod.PathsAndFiles import System.FilePath +import Paths_ghc_mod as GhcMod + -- | Only package related GHC options, sufficient for things that don't need to -- access home modules getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(ChComponentName, [GHCOption])] @@ -87,6 +90,7 @@ cabalHelperCache = Cached { , a == a' ] + withCabal :: (MonadIO m, GmEnv m) => m a -> m a withCabal action = do crdl <- cradle diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 02b4ba7..23a902b 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -1,9 +1,10 @@ -module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where +module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where import Control.Arrow (first) import Control.Applicative ((<$>)) import qualified Data.Map as Map import qualified Data.Set as Set +import Data.Char import Text.PrettyPrint import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad @@ -35,8 +36,8 @@ debugInfo = do cabalDebug :: IOish m => GhcModT m [String] cabalDebug = do - Cradle {..} <- cradle - mcs <- resolveGmComponents Nothing =<< getComponents + crdl@Cradle {..} <- cradle + mcs <- resolveGmComponents Nothing =<< mapM (resolveEntrypoint crdl) =<< getComponents let entrypoints = Map.map gmcEntrypoints mcs graphs = Map.map gmcHomeModuleGraph mcs opts = Map.map gmcGhcOpts mcs @@ -54,6 +55,20 @@ cabalDebug = do mapDoc gmComponentNameDoc (fsep . map text) srcOpts) ] +componentInfo :: IOish m => [String] -> GhcModT m String +componentInfo ts = do + crdl <- cradle + opts <- targetGhcOptions crdl $ Set.fromList $ map guessModuleFile ts + + return $ unlines $ + [ "GHC Cabal options:\n" ++ render (nest 4 $ fsep $ map text opts) + ] + +guessModuleFile :: String -> Either FilePath ModuleName +guessModuleFile mn@(h:r) + | isUpper h && all isAlphaNum r = Right $ mkModuleName mn +guessModuleFile str = Left str + graphDoc :: GmModuleGraph -> Doc graphDoc GmModuleGraph{..} = mapDoc mpDoc' smpDoc' gmgGraph diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index 442a108..37ec5b1 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -216,7 +216,7 @@ updateHomeModuleGraph' env smp0 = do Left errs -> do -- TODO: Remember these and present them as proper errors if this is -- the file the user is looking at. - gmLog GmWarning "preprocess'" $ vcat $ map strDoc errs + gmLog GmWarning ("preprocess' " ++ show fn) $ vcat $ map strDoc errs return Nothing imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath) diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 4fd006d..f028a28 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -14,6 +14,8 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Language.Haskell.GhcMod.Logging ( module Language.Haskell.GhcMod.Logging , module Language.Haskell.GhcMod.Pretty @@ -22,7 +24,9 @@ module Language.Haskell.GhcMod.Logging ( , module Data.Monoid ) where +import Control.Applicative hiding (empty) import Control.Monad +import Control.Monad.Trans.Class import Data.List import Data.Char import Data.Monoid (mempty, mappend, mconcat, (<>)) @@ -57,9 +61,20 @@ gmLog level loc' doc = do let loc | loc' == "" = empty | otherwise = text loc' - msg = gmRenderDoc $ (gmLogLevelDoc level <+> loc) <+>: doc + msg = gmRenderDoc $ (gmLogLevelDoc level <+>: loc) <+>: doc msg' = dropWhileEnd isSpace msg when (Just level <= level') $ liftIO $ hPutStrLn stderr msg' gmlJournal (GhcModLog Nothing [(level, render loc, msg)]) + +newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a } + deriving (Functor, Applicative, Monad) + +instance MonadTrans LogDiscardT where + lift = LogDiscardT + +instance Monad m => GmLog (LogDiscardT m) where + gmlJournal = const $ return () + gmlHistory = return mempty + gmlClear = return () diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index b6ee787..d211966 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -27,14 +27,14 @@ module Language.Haskell.GhcMod.Monad.Types ( , LightGhc(..) , GmGhc , IOish - -- ** Environment, state and logging + -- * Environment, state and logging , GhcModEnv(..) , GhcModState(..) , defaultGhcModState , GmGhcSession(..) , GmComponent(..) , CompilerMode(..) - -- ** Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog' + -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog' , GmLogLevel(..) , GhcModLog(..) , GhcModError(..) @@ -46,7 +46,7 @@ module Language.Haskell.GhcMod.Monad.Types ( , withOptions , getCompilerMode , setCompilerMode - -- ** Re-exporting convenient stuff + -- * Re-exporting convenient stuff , MonadIO , liftIO ) where diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 8f51037..37c7220 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -72,18 +72,20 @@ Library Default-Language: Haskell2010 GHC-Options: -Wall -fno-warn-deprecations Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, - ConstraintKinds, FlexibleContexts + ConstraintKinds, FlexibleContexts, + DataKinds, KindSignatures Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Internal Other-Modules: Paths_ghc_mod Utils Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Browse + Language.Haskell.GhcMod.CabalHelper + Language.Haskell.GhcMod.Caching Language.Haskell.GhcMod.CaseSplit Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Convert Language.Haskell.GhcMod.Cradle - Language.Haskell.GhcMod.CabalHelper Language.Haskell.GhcMod.Debug Language.Haskell.GhcMod.Doc Language.Haskell.GhcMod.DynFlags @@ -113,6 +115,7 @@ Library Language.Haskell.GhcMod.World Build-Depends: base >= 4.0 && < 5 , bytestring + , cereal >= 0.4 , containers , cabal-helper >= 0.3 , deepseq @@ -200,7 +203,8 @@ Test-Suite doctest Test-Suite spec Default-Language: Haskell2010 Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, - ConstraintKinds, FlexibleContexts + ConstraintKinds, FlexibleContexts, + DataKinds, KindSignatures Main-Is: Main.hs Hs-Source-Dirs: test, . Ghc-Options: -Wall -fno-warn-deprecations diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 4a6c680..df1985b 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -196,6 +196,9 @@ ghcModUsage = \ Print debugging information. Please include the output in any bug\n\ \ reports you submit.\n\ \\n\ + \ - debugComponent [MODULE_OR_FILE...]\n\ + \ Debugging information related to cabal component resolution.\n\ + \\n\ \ - boot\n\ \ Internal command used by the emacs frontend.\n" -- "\n\ @@ -514,6 +517,7 @@ ghcCommands (cmd:args) = fn args "check" -> checkSyntaxCmd "expand" -> expandTemplateCmd "debug" -> debugInfoCmd + "debugComponent" -> componentInfoCmd "info" -> infoCmd "type" -> typesCmd "split" -> splitsCmd @@ -565,7 +569,7 @@ catchArgs cmd action = throw $ InvalidCommandLine (Left cmd) modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd, - debugInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd, + debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd :: IOish m => [String] -> GhcModT m String @@ -575,6 +579,7 @@ languagesCmd = withParseCmd' "lang" [] $ \[] -> languages flagsCmd = withParseCmd' "flag" [] $ \[] -> flags debugInfoCmd = withParseCmd' "debug" [] $ \[] -> debugInfo rootInfoCmd = withParseCmd' "root" [] $ \[] -> rootInfo +componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts -- internal bootCmd = withParseCmd' "boot" [] $ \[] -> boot diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs index fd1c4d4..9e832c2 100644 --- a/test/CabalHelperSpec.hs +++ b/test/CabalHelperSpec.hs @@ -2,16 +2,16 @@ module CabalHelperSpec where import Control.Arrow import Control.Applicative -import Language.Haskell.GhcMod.CabalHelper -import Language.Haskell.GhcMod.PathsAndFiles +-- import Language.Haskell.GhcMod.CabalHelper +-- import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Error import Test.Hspec -import System.Directory -import System.FilePath -import System.Process (readProcess) +-- import System.Directory +-- import System.FilePath +-- import System.Process (readProcess) -import Dir -import TestUtils +-- import Dir +-- import TestUtils import Data.List import Config (cProjectVersionInt) @@ -36,35 +36,35 @@ idirOpts :: [(c, [String])] -> [(c, [String])] idirOpts = map (second $ map (drop 2) . filter ("-i"`isPrefixOf`)) spec :: Spec -spec = do - describe "getGhcOptions" $ do - it "throws an exception if the cabal file is broken" $ do - let tdir = "test/data/broken-caba" - runD' tdir getGhcOptions `shouldThrow` anyIOException +spec = do return () + -- describe "getGhcOptions" $ do + -- it "throws an exception if the cabal file is broken" $ do + -- let tdir = "test/data/broken-caba" + -- runD' tdir getGhcOptions `shouldThrow` anyIOException - it "handles sandboxes correctly" $ do - let tdir = "test/data/cabal-project" - cwd <- getCurrentDirectory + -- it "handles sandboxes correctly" $ do + -- let tdir = "test/data/cabal-project" + -- cwd <- getCurrentDirectory - opts <- runD' tdir getGhcOptions + -- opts <- runD' tdir getGhcOptions - if ghcVersion < 706 - then forM_ opts (\(_, o) -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) - else forM_ opts (\(_, o) -> o `shouldContain` ["-no-user-package-db","-package-db",cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) + -- if ghcVersion < 706 + -- then forM_ opts (\(_, o) -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) + -- else forM_ opts (\(_, o) -> o `shouldContain` ["-no-user-package-db","-package-db",cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) - it "extracts build dependencies" $ do - let tdir = "test/data/cabal-project" - opts <- runD' tdir getGhcOptions - let ghcOpts = snd $ head opts - pkgs = pkgOptions ghcOpts - pkgs `shouldBe` ["Cabal","base","template-haskell"] + -- it "extracts build dependencies" $ do + -- let tdir = "test/data/cabal-project" + -- opts <- runD' tdir getGhcOptions + -- let ghcOpts = snd $ head opts + -- pkgs = pkgOptions ghcOpts + -- pkgs `shouldBe` ["Cabal","base","template-haskell"] - it "uses non default flags" $ do - let tdir = "test/data/cabal-flags" - _ <- withDirectory_ tdir $ - readProcess "cabal" ["configure", "-ftest-flag"] "" + -- it "uses non default flags" $ do + -- let tdir = "test/data/cabal-flags" + -- _ <- withDirectory_ tdir $ + -- readProcess "cabal" ["configure", "-ftest-flag"] "" - opts <- runD' tdir getGhcOptions - let ghcOpts = snd $ head opts - pkgs = pkgOptions ghcOpts - pkgs `shouldBe` ["Cabal","base"] + -- opts <- runD' tdir getGhcOptions + -- let ghcOpts = snd $ head opts + -- pkgs = pkgOptions ghcOpts + -- pkgs `shouldBe` ["Cabal","base"] diff --git a/test/Main.hs b/test/Main.hs index 8ebe5eb..4422d5a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -29,9 +29,8 @@ main = do genGhcPkgCache `mapM_` pkgDirs let caches = [ "setup-config" - , "setup-config.ghc-mod.cabal-ghc-options" - , "setup-config.ghc-mod.cabal-helper.ghc-options" , "setup-config.ghc-mod.cabal-helper" + , "setup-config.ghc-mod.resolved-components" , "ghc-mod.cache" ] cachesFindExp :: String @@ -39,10 +38,9 @@ main = do cleanCmd = "find test \\( "++ cachesFindExp ++" \\) -exec rm {} \\;" - print cleanCmd + putStrLn $ "$ " ++ cleanCmd void $ system cleanCmd void $ system "cabal --version" - putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal void $ system "ghc --version" (putStrLn =<< runD debugInfo) diff --git a/test/data/check-test-subdir/check-test-subdir.cabal b/test/data/check-test-subdir/check-test-subdir.cabal index 75d6ee1..315b549 100644 --- a/test/data/check-test-subdir/check-test-subdir.cabal +++ b/test/data/check-test-subdir/check-test-subdir.cabal @@ -13,3 +13,4 @@ test-suite test build-depends: base == 4.* hs-source-dirs: test main-is: Main.hs + ghc-options: -Wall diff --git a/test/data/pattern-synonyms/pattern-synonyms.cabal b/test/data/pattern-synonyms/pattern-synonyms.cabal index 06cf5fd..ab75969 100644 --- a/test/data/pattern-synonyms/pattern-synonyms.cabal +++ b/test/data/pattern-synonyms/pattern-synonyms.cabal @@ -21,4 +21,5 @@ library other-extensions: PatternSynonyms build-depends: base -- hs-source-dirs: - default-language: Haskell2010 \ No newline at end of file + default-language: Haskell2010 + ghc-options: -Wall \ No newline at end of file From 744f2c232c0ee64d2c59046c86e4dfdbe29ab1b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 28 Mar 2015 02:35:17 +0100 Subject: [PATCH 054/207] Update cabal meta data --- ghc-mod.cabal | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 37c7220..96cf525 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,7 +1,7 @@ Name: ghc-mod Version: 0 -Author: Kazu Yamamoto - Daniel Gröber +Author: Kazu Yamamoto , + Daniel Gröber , Alejandro Serrano Maintainer: Daniel Gröber License: AGPL-3 @@ -9,17 +9,21 @@ License-File: LICENSE License-Files: COPYING.BSD3 COPYING.AGPL3 Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ Synopsis: Happy Haskell Programming -Description: The ghc-mod command is a backend command to enrich - Haskell programming on editors including - Emacs, Vim, and Sublime. - The ghc-mod command is based on ghc-mod library - which is a wrapper of GHC API. - This package includes the ghc-mod command, - the ghc-mod library, and Emacs front-end - (for historical reasons). - For more information, please see its home page. +Description: + ghc-mod is a backend program to enrich Haskell programming in editors. It + strives to offer most of the features one has come to expect from modern IDEs + in any editor. -Category: Development + ghc-mod provides a library for other haskell programs to use as well as a + standalone program for easy editor integration. All of the fundamental + functionality of the frontend program can be accessed through the library + however many implementation details are hidden and if you want to + significantly extend ghc-mod you should submit these changes upstream instead + of implementing them on top of the library. + + For more information, please see its home page. + +Category: GHC, Development Cabal-Version: >= 1.16 Build-Type: Custom Data-Files: elisp/Makefile From 340ff1e4a768bfbeaeb0b4fec486ce79cf8583db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 28 Mar 2015 02:35:36 +0100 Subject: [PATCH 055/207] Update README --- README.md | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 713c935..2065673 100644 --- a/README.md +++ b/README.md @@ -47,7 +47,11 @@ all sorts of nasty conflicts. ## IRC If you have any problems, suggestions, comments swing by -[#ghc-mod](irc://chat.freenode.net/ghc-mod) on Freenode. +[\#ghc-mod (web client)](https://kiwiirc.com/client/irc.freenode.org/ghc-mod) on +Freenode. If you're reporting a bug please also create an issue +[here](https://github.com/DanielG/ghc-mod/issues) so we have a way to contact +you if you don't have time to stay. Do hang around for a while if no one answers and repeat your question if you -still haven't gotten any answer after a day or so. +still haven't gotten any answer after a day or so. You're most likely to get an +answer during the day in GMT+1. From e3812b49ecd6b503916ea440630f8ca673242320 Mon Sep 17 00:00:00 2001 From: Markus Hauck Date: Thu, 29 Jan 2015 09:43:31 +0100 Subject: [PATCH 056/207] GHC 7.10.0.20150123 fixes --- Language/Haskell/GhcMod/CaseSplit.hs | 2 +- Language/Haskell/GhcMod/FillSig.hs | 9 +++++++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index 890bee0..aab4dc3 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -92,7 +92,7 @@ getSrcSpanTypeForFnSplit modSum lineNo colNo = do varT <- Gap.getType tcm varPat' -- Finally we get the type of the var case varT of Just varT' -> - let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match + let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) ) _ -> return Nothing diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 12a6e6b..f9be127 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -143,7 +143,12 @@ getSignature modSum lineNo colNo = do G.TypeFamily -> Open G.DataFamily -> Data #endif -#if __GLASGOW_HASKELL__ >= 706 + +#if __GLASGOW_HASKELL__ >= 710 + getTyFamVarName x = case x of + L _ (G.UserTyVar n) -> n + L _ (G.KindedTyVar (G.L _ n) _) -> n +#elif __GLASGOW_HASKELL__ >= 706 getTyFamVarName x = case x of L _ (G.UserTyVar n) -> n L _ (G.KindedTyVar n _) -> n @@ -476,7 +481,7 @@ getPatsForVariable tcs (lineNo, colNo) = #else :: [G.LMatch Id] #endif - (L _ (G.Match pats _ _):_) = m + (L _ (G.Match _ pats _ _):_) = m in (funId, pats) _ -> (error "This should never happen", []) From 97d17b1173b974612e6c5ccc904a1f2f3987f241 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 28 Mar 2015 19:11:09 +0100 Subject: [PATCH 057/207] SetupCompat.hs: remove dependnece on mtl --- SetupCompat.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SetupCompat.hs b/SetupCompat.hs index 13707fc..b35b3eb 100644 --- a/SetupCompat.hs +++ b/SetupCompat.hs @@ -2,7 +2,7 @@ module SetupCompat where import Control.Arrow -import Control.Monad.State.Strict +import Control.Monad.Trans.State import Data.List import Data.Maybe import Data.Functor From 55216e4af326149200ec16e5e1805a004815e25d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 28 Mar 2015 19:54:10 +0100 Subject: [PATCH 058/207] ifdef for ghc < 7.10 --- Language/Haskell/GhcMod/CaseSplit.hs | 4 ++++ Language/Haskell/GhcMod/FillSig.hs | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index aab4dc3..0a5c810 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -92,7 +92,11 @@ getSrcSpanTypeForFnSplit modSum lineNo colNo = do varT <- Gap.getType tcm varPat' -- Finally we get the type of the var case varT of Just varT' -> +#if __GLASGOW_HASKELL__ >= 710 let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match +#else + let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match +#endif in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) ) _ -> return Nothing diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index f9be127..092248a 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -481,7 +481,11 @@ getPatsForVariable tcs (lineNo, colNo) = #else :: [G.LMatch Id] #endif +#if __GLASGOW_HASKELL__ >= 710 (L _ (G.Match _ pats _ _):_) = m +#else + (L _ (G.Match pats _ _):_) = m +#endif in (funId, pats) _ -> (error "This should never happen", []) From f3b4da7a0e2cd137df565982a136528ca519dfc4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 12 Apr 2015 02:39:55 +0200 Subject: [PATCH 059/207] Use cabal-helper to get `buildPlatform` --- Language/Haskell/GhcMod/PathsAndFiles.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index b1dcda3..14c04bc 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -26,13 +26,13 @@ import Data.List import Data.Char import Data.Maybe import Data.Traversable (traverse) +import Distribution.Helper (buildPlatform) import System.Directory import System.FilePath import System.IO.Unsafe import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.Utils hiding (dropWhileEnd) import Language.Haskell.GhcMod.Caching import qualified Language.Haskell.GhcMod.Utils as U @@ -185,8 +185,7 @@ ghcSandboxPkgDbDir = cabalBuildPlatform ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d" cabalBuildPlatform :: String -cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $ - readLibExecProcess' "cabal-helper-wrapper" ["print-build-platform"] +cabalBuildPlatform = unsafePerformIO $ buildPlatform packageCache :: String packageCache = "package.cache" From d0ca3ee807e9a9f2f035e692ba20151254adfd4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 3 Apr 2015 01:15:12 +0200 Subject: [PATCH 060/207] Fix MonadIO mess --- Language/Haskell/GhcMod/CaseSplit.hs | 3 +- Language/Haskell/GhcMod/Error.hs | 1 - Language/Haskell/GhcMod/FillSig.hs | 3 +- Language/Haskell/GhcMod/HomeModuleGraph.hs | 2 +- Language/Haskell/GhcMod/Logger.hs | 7 +- Language/Haskell/GhcMod/Monad/Types.hs | 79 ++++++++++++---------- Language/Haskell/GhcMod/Types.hs | 23 +++++-- 7 files changed, 72 insertions(+), 46 deletions(-) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index 0a5c810..77603ca 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -195,7 +195,8 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x ---------------------------------------------------------------- -- c. Code for performing the case splitting -genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String +genCaseSplitTextFile :: (MonadIO m, GhcMonad m) => + FilePath -> SplitToTextInfo -> m String genCaseSplitTextFile file info = liftIO $ do t <- T.readFile file return $ getCaseSplitText (T.lines t) info diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index cefdc0e..965aa7e 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -49,7 +49,6 @@ import Config (cProjectVersion, cHostPlatformString) import Paths_ghc_mod (version) import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Pretty type GmError m = MonadError GhcModError m diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 092248a..94f324c 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -167,7 +167,8 @@ getSignature modSum lineNo colNo = do return $ InstanceDecl loc cls -- Get signature from haskell-src-exts -getSignatureFromHE :: GhcMonad m => FilePath -> Int -> Int -> m (Maybe HESigInfo) +getSignatureFromHE :: (MonadIO m, GhcMonad m) => + FilePath -> Int -> Int -> m (Maybe HESigInfo) getSignatureFromHE file lineNo colNo = do presult <- liftIO $ HE.parseFile file return $ case presult of diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index 37ec5b1..09bfc08 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -36,9 +36,9 @@ import Exception import Finder import GHC import HscTypes -import MonadUtils hiding (foldrM) import Control.Arrow ((&&&)) +import Control.Applicative ((<$>)) import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.State.Strict (execStateT) diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 088c251..cba6858 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -2,6 +2,7 @@ module Language.Haskell.GhcMod.Logger ( withLogger , withLogger' , checkErrorPrefix + , errsToStr ) where import Control.Arrow @@ -96,10 +97,10 @@ withLogger' env action = do -- | Converting 'SourceError' to 'String'. sourceError :: DynFlags -> PprStyle -> SourceError -> [String] -sourceError df st src_err = errBagToStrList df st $ srcErrorMessages src_err +sourceError df st src_err = errsToStr df st $ reverse $ bagToList $ srcErrorMessages src_err -errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] -errBagToStrList df st = map (ppErrMsg df st) . reverse . bagToList +errsToStr :: DynFlags -> PprStyle -> [ErrMsg] -> [String] +errsToStr df st = map (ppErrMsg df st) ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index d211966..ab644db 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -78,6 +78,7 @@ import Control.Monad.Reader (ReaderT(..)) import Control.Monad.Error (ErrorT(..), MonadError(..)) import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Trans.Maybe (MaybeT) import Control.Monad.Base (MonadBase(..), liftBase) import Control.Monad.Trans.Control @@ -87,14 +88,10 @@ import Control.Monad.Writer.Class import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Journal.Class (MonadJournal(..)) import Control.Monad.Trans.Class (MonadTrans(..)) - -#ifdef MONADIO_INSTANCES -import Control.Monad.Trans.Maybe (MaybeT) import Control.Monad.Error (Error(..)) -#endif +import qualified Control.Monad.IO.Class as MTL #if DIFFERENT_MONADIO -import qualified Control.Monad.IO.Class import Data.Monoid (Monoid) #endif @@ -105,7 +102,7 @@ import Data.Monoid import Data.IORef import Distribution.Helper -import MonadUtils (MonadIO(..)) +import qualified MonadUtils as GHC (MonadIO(..)) data GhcModEnv = GhcModEnv { gmOptions :: Options @@ -159,8 +156,9 @@ newtype GhcModT m a = GhcModT { , Alternative , Monad , MonadPlus + , MTL.MonadIO #if DIFFERENT_MONADIO - , Control.Monad.IO.Class.MonadIO + , GHC.MonadIO #endif , MonadError GhcModError ) @@ -172,9 +170,9 @@ newtype GmlT m a = GmlT { unGmlT :: GhcModT m a } , Monad , MonadPlus , MonadTrans - , MonadIO + , MTL.MonadIO #if DIFFERENT_MONADIO - , Control.Monad.IO.Class.MonadIO + , GHC.MonadIO #endif , MonadError GhcModError , GmEnv @@ -186,12 +184,43 @@ newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a } deriving ( Functor , Applicative , Monad - , MonadIO + , MTL.MonadIO #if DIFFERENT_MONADIO - , Control.Monad.IO.Class.MonadIO + , GHC.MonadIO #endif ) +#if DIFFERENT_MONADIO +instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where + liftIO = MTL.liftIO +instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where + liftIO = MTL.liftIO +#endif + +instance MonadIO IO where + liftIO = id +instance MonadIO m => MonadIO (ReaderT x m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (StateT x m) where + liftIO = MTL.liftIO +instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (JournalT x m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (MaybeT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GhcModT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GmlT m) where + liftIO = MTL.liftIO +instance MonadIO LightGhc where + liftIO = MTL.liftIO class Monad m => GmEnv m where gmeAsk :: m GhcModEnv @@ -263,9 +292,6 @@ instance (Monad m, GmLog m) => GmLog (StateT s m) where gmlHistory = lift gmlHistory gmlClear = lift gmlClear -instance MonadIO m => MonadIO (GhcModT m) where - liftIO action = GhcModT $ liftIO action - instance Monad m => MonadJournal GhcModLog (GhcModT m) where journal !w = GhcModT $ lift $ lift $ (journal w) history = GhcModT $ lift $ lift $ history @@ -291,23 +317,6 @@ instance MonadState s m => MonadState s (GhcModT m) where put = GhcModT . lift . lift . lift . put state = GhcModT . lift . lift . lift . state -#if MONADIO_INSTANCES -instance MonadIO m => MonadIO (StateT s m) where - liftIO = lift . liftIO - -instance MonadIO m => MonadIO (ReaderT r m) where - liftIO = lift . liftIO - -instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where - liftIO = lift . liftIO - -instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where - liftIO = lift . liftIO - -instance MonadIO m => MonadIO (MaybeT m) where - liftIO = lift . liftIO -#endif - instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where liftBase = GmlT . liftBase @@ -370,14 +379,14 @@ type GmGhc m = (IOish m, GhcMonad m) instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where getSession = do ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet - liftIO $ readIORef ref + GHC.liftIO $ readIORef ref setSession a = do ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet - liftIO $ flip writeIORef a ref + GHC.liftIO $ flip writeIORef a ref instance GhcMonad LightGhc where - getSession = (liftIO . readIORef) =<< LightGhc ask - setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask + getSession = (GHC.liftIO . readIORef) =<< LightGhc ask + setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask #if __GLASGOW_HASKELL__ >= 706 instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index dd2370d..6430b6b 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric, StandaloneDeriving, - DefaultSignatures #-} +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, + StandaloneDeriving, DefaultSignatures, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} module Language.Haskell.GhcMod.Types ( module Language.Haskell.GhcMod.Types @@ -10,6 +10,7 @@ module Language.Haskell.GhcMod.Types ( import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Error (Error(..)) +import qualified Control.Monad.IO.Class as MTL import Control.Exception (Exception) import Control.Applicative import Control.Arrow @@ -25,7 +26,9 @@ import Data.Maybe import Data.Typeable (Typeable) import Distribution.Helper import Exception (ExceptionMonad) -import MonadUtils (MonadIO) +#if __GLASGOW_HASKELL__ < 708 +import qualified MonadUtils as GHC (MonadIO(..)) +#endif import GHC (ModuleName, moduleNameString, mkModuleName) import PackageConfig (PackageConfig) import GHC.Generics @@ -38,6 +41,18 @@ import GHC.Generics -- the exported API so users have the option to use a custom inner monad. type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m) + +-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. +-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. +#if __GLASGOW_HASKELL__ < 708 +type MonadIOC m = (GHC.MonadIO m, MTL.MonadIO m) +#else +type MonadIOC m = (MTL.MonadIO m) +#endif + +class MonadIOC m => MonadIO m where + liftIO :: IO a -> m a + -- | Output style. data OutputStyle = LispStyle -- ^ S expression style. | PlainStyle -- ^ Plain textstyle. @@ -208,7 +223,7 @@ data GmComponent (t :: GmComponentType) eps = GmComponent { gmcEntrypoints :: eps, gmcSourceDirs :: [FilePath], gmcHomeModuleGraph :: GmModuleGraph - } deriving (Eq, Ord, Show, Read, Generic, Typeable, Functor) + } deriving (Eq, Ord, Show, Read, Generic, Functor) instance Serialize eps => Serialize (GmComponent t eps) From 523f43c3c957e2b737e7e7ae1f0d64f398de08a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 11 Apr 2015 16:40:27 +0200 Subject: [PATCH 061/207] Fix some tests --- .travis.yml | 5 ++--- Language/Haskell/GhcMod/Logger.hs | 2 +- ghc-mod.cabal | 11 ++++++----- test/doctests.hs | 2 +- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/.travis.yml b/.travis.yml index fd3a6b1..1322045 100644 --- a/.travis.yml +++ b/.travis.yml @@ -10,11 +10,10 @@ install: # - ( $CABAL122 && cabal install cabal-install --constraint "Cabal >= 1.22" && ghc-pkg unregister Cabal ) || true - echo $PATH - which cabal - - cabal install cabal-install --constraint "Cabal == $(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | awk -vFS=. '{ print $1 "." $2 }' | tail -n1).*" # - cabal install Cabal --constraint "Cabal == $(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | tail -n1)" - cabal install happy - happy --version - - cabal install -j --only-dependencies --enable-tests + - cabal install -j --only-dependencies --enable-tests --constraint "tagged < 0.8" script: - touch ChangeLog # Create ChangeLog if we're not on the release branch @@ -27,7 +26,7 @@ script: - if [ -n "$(ghc --version | awk '{ print $8 }' | sed -n '/^7.8/p')" ]; then export WERROR="--ghc-option=-Werror"; fi - cabal configure --enable-tests $WERROR - cabal build - - export ghc_mod_libexecdir=$PWD/dist/build/cabal-helper-wrapper + - export cabal_helper_libexecdir=$HOME/.cabal/bin - export ghc_mod_datadir=$PWD - cabal test diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index cba6858..8778d33 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -13,12 +13,12 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import System.FilePath (normalise) import Text.PrettyPrint -import Bag (Bag, bagToList) import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo) import GHC (DynFlags, SrcSpan, Severity(SevError)) import HscTypes import Outputable import qualified GHC as G +import Bag import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Doc (showPage) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 96cf525..9fc8b57 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -24,7 +24,7 @@ Description: For more information, please see its home page. Category: GHC, Development -Cabal-Version: >= 1.16 +Cabal-Version: >= 1.14 Build-Type: Custom Data-Files: elisp/Makefile elisp/*.el @@ -121,7 +121,7 @@ Library , bytestring , cereal >= 0.4 , containers - , cabal-helper >= 0.3 + , cabal-helper >= 0.3.1.0 , deepseq , directory , filepath @@ -146,9 +146,10 @@ Library , djinn-ghc >= 0.0.2.2 if impl(ghc < 7.8) Build-Depends: convertible - if impl(ghc <= 7.4.2) + if impl(ghc < 7.5) -- Only used to constrain random to a version that still works with GHC 7.4 - Build-Depends: random <= 1.0.1.1 + Build-Depends: random <= 1.0.1.1, + ghc-prim Executable ghc-mod Default-Language: Haskell2010 @@ -229,7 +230,7 @@ Test-Suite spec PathsAndFilesSpec HomeModuleGraphSpec - Build-Depends: hspec + Build-Depends: hspec >= 2.0.0 if impl(ghc == 7.4.*) Build-Depends: executable-path X-Build-Depends-Like: CLibName diff --git a/test/doctests.hs b/test/doctests.hs index a591638..08da97b 100644 --- a/test/doctests.hs +++ b/test/doctests.hs @@ -9,7 +9,7 @@ main = doctest , "-package", "transformers-" ++ VERSION_transformers , "-package", "mtl-" ++ VERSION_mtl , "-package", "directory-" ++ VERSION_directory - , "-XConstraintKinds", "-XFlexibleContexts", "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns" + , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures" , "-idist/build/autogen/" , "-optP-include" , "-optPdist/build/autogen/cabal_macros.h" From 6f59f07f00314d51cd8a6804ce09617b4326b4bb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 11 Apr 2015 16:41:17 +0200 Subject: [PATCH 062/207] Fix non canonicalized paths --- Language/Haskell/GhcMod/HomeModuleGraph.hs | 33 +++++++++++++--------- Language/Haskell/GhcMod/Target.hs | 13 +++++---- Language/Haskell/GhcMod/Types.hs | 12 +++----- 3 files changed, 31 insertions(+), 27 deletions(-) diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index 09bfc08..f42c6db 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -24,13 +24,16 @@ module Language.Haskell.GhcMod.HomeModuleGraph ( , findModulePath , findModulePathSet , fileModuleName + , canonicalizeModulePath , homeModuleGraph , updateHomeModuleGraph + , canonicalizeModuleGraph , reachable , moduleGraphToDot ) where import DriverPipeline +import DynFlags import ErrUtils import Exception import Finder @@ -45,14 +48,17 @@ import Control.Monad.State.Strict (execStateT) import Control.Monad.State.Class import Data.Maybe import Data.Monoid +import Data.Traversable as T (mapM) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import System.FilePath +import System.Directory import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Logger +import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Gap (parseModuleHeader) @@ -111,12 +117,8 @@ reachable smp0 GmModuleGraph {..} = go smp0 pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph pruneUnreachable smp0 gmg@GmModuleGraph {..} = let r = reachable smp0 gmg - rfn = Set.map mpPath r - rmn = Set.map mpModule r in GmModuleGraph { - gmgFileMap = Map.filterWithKey (\k _ -> k `Set.member` rfn) gmgFileMap, - gmgModuleMap = Map.filterWithKey (\k _ -> k `Set.member` rmn) gmgModuleMap, gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph } @@ -143,29 +145,37 @@ find env mn = liftIO $ do res <- findHomeModule env mn case res of -- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc - Found loc@ModLocation { ml_hs_file = Just _ } _mod -> do + Found loc@ModLocation { ml_hs_file = Just _ } _mod -> return $ normalise <$> ml_hs_file loc _ -> return Nothing + +canonicalizeModulePath (ModulePath mn fp) = ModulePath mn <$> canonicalizePath fp + +canonicalizeModuleGraph :: MonadIO m => GmModuleGraph -> m GmModuleGraph +canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do + GmModuleGraph . Map.fromList <$> mapM fmg (Map.toList gmgGraph) + where + fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp)) + + updateHomeModuleGraph :: (IOish m, GmLog m, GmEnv m) => HscEnv -> GmModuleGraph -> Set ModulePath -- ^ Initial set of modules -> Set ModulePath -- ^ Updated set of modules -> m GmModuleGraph -updateHomeModuleGraph env GmModuleGraph {..} smp usmp = do +updateHomeModuleGraph env GmModuleGraph {..} smp sump = do -- TODO: It would be good if we could retain information about modules that -- stop to compile after we've already successfully parsed them at some -- point. Figure out a way to delete the modules about to be updated only -- after we're sure they won't fail to parse .. or something. Should probably -- push this whole prune logic deep into updateHomeModuleGraph' - (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env usmp) + (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env sump) where runS = flip execStateT defaultS { sGraph = graph' } graph' = GmModuleGraph { - gmgFileMap = Set.foldr (Map.delete . mpPath) gmgFileMap usmp, - gmgModuleMap = Set.foldr (Map.delete . mpModule) gmgModuleMap usmp, - gmgGraph = Set.foldr Map.delete gmgGraph usmp + gmgGraph = Set.foldr Map.delete gmgGraph sump } mkFileMap :: Set ModulePath -> Map FilePath ModulePath @@ -181,7 +191,6 @@ updateHomeModuleGraph' -> m () updateHomeModuleGraph' env smp0 = do go `mapM_` Set.toList smp0 - where go :: ModulePath -> m () go mp = do @@ -192,8 +201,6 @@ updateHomeModuleGraph' env smp0 = do smp <- collapseMaybeSet `liftM` step mp graphUnion GmModuleGraph { - gmgFileMap = mkFileMap smp, - gmgModuleMap = mkModuleMap smp, gmgGraph = Map.singleton mp smp } diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 3a7c78d..6231683 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -142,15 +142,15 @@ runGmlTWith efnmns' mdf wrapper action = do let (fns, mns) = partitionEithers efnmns' ccfns = map (cradleCurrentDir crdl ) fns cfns <- liftIO $ mapM canonicalizePath ccfns - let rfns = map (makeRelative $ cradleRootDir crdl) cfns - serfnmn = Set.fromList $ map Right mns ++ map Left rfns - + let serfnmn = Set.fromList $ map Right mns ++ map Left cfns opts <- targetGhcOptions crdl serfnmn let opts' = opts ++ ghcUserOptions initSession opts' $ setModeSimple >>> setEmptyLogger >>> mdf + let rfns = map (makeRelative $ cradleRootDir crdl) cfns + unGmlT $ wrapper $ do loadTargets (map moduleNameString mns ++ rfns) action @@ -268,7 +268,7 @@ resolveGmComponent mums c@GmComponent {..} = do Nothing -> return simp Just ums -> Set.fromList . catMaybes <$> mapM (resolveModule env srcDirs) ums - mg' <- updateHomeModuleGraph env mg simp sump + mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' } @@ -285,13 +285,14 @@ resolveEntrypoint Cradle {..} c@GmComponent {..} = resolveModule :: MonadIO m => HscEnv -> [FilePath] -> Either FilePath ModuleName -> m (Maybe ModulePath) -resolveModule env _srcDirs (Right mn) = liftIO $ findModulePath env mn +resolveModule env _srcDirs (Right mn) = + liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn resolveModule env srcDirs (Left fn') = liftIO $ do mfn <- findFile' srcDirs fn' case mfn of Nothing -> return Nothing Just fn'' -> do - let fn = normalise fn'' + fn <- canonicalizePath fn'' emn <- fileModuleName env fn return $ case emn of Left _ -> Nothing diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 6430b6b..fcc0199 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -177,8 +177,6 @@ data GmLogLevel = GmPanic type PkgDb = (Map Package PackageConfig) data GmModuleGraph = GmModuleGraph { - gmgFileMap :: Map FilePath ModulePath, - gmgModuleMap :: Map ModuleName ModulePath, gmgGraph :: Map ModulePath (Set ModulePath) } deriving (Eq, Ord, Show, Read, Generic, Typeable) @@ -204,14 +202,12 @@ instance Serialize GmModuleGraph where intToMp i = fromJust $ Map.lookup i impm mpGraph :: Map ModulePath (Set ModulePath) mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph - mpFm = Map.fromList $ map (mpPath &&& id) $ Map.keys mpim - mpMn = Map.fromList $ map (mpModule &&& id) $ Map.keys mpim - return $ GmModuleGraph mpFm mpMn mpGraph + return $ GmModuleGraph mpGraph instance Monoid GmModuleGraph where - mempty = GmModuleGraph mempty mempty mempty - mappend (GmModuleGraph a b c) (GmModuleGraph a' b' c') = - GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c') + mempty = GmModuleGraph mempty + mappend (GmModuleGraph a) (GmModuleGraph a') = + GmModuleGraph (Map.unionWith Set.union a a') data GmComponentType = GMCRaw | GMCResolved From ca79f99c3ec982399ee7af2adb3fdddd7a0e71bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 12 Apr 2015 02:36:17 +0200 Subject: [PATCH 063/207] Also add language options when resolving components --- Language/Haskell/GhcMod/CabalHelper.hs | 13 +++++++++---- Language/Haskell/GhcMod/PathsAndFiles.hs | 3 +++ Language/Haskell/GhcMod/Target.hs | 12 ++++++++++-- Language/Haskell/GhcMod/Types.hs | 2 +- ghc-mod.cabal | 2 +- 5 files changed, 24 insertions(+), 8 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 85b90d0..ed0bc5c 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -76,13 +76,18 @@ cabalHelperCache = Cached { cacheFile = cabalHelperCacheFile, cachedAction = \ _ (progs, root, _) -> runQuery' progs root $ do - q <- liftM4 join4 ghcOptions ghcSrcOptions entrypoints sourceDirs - let cs = flip map q $ \(cn, (opts, (srcOpts, (ep, srcDirs)))) -> - GmComponent cn opts srcOpts ep ep srcDirs mempty + q <- liftM5 join5 + ghcOptions + ghcSrcOptions + ghcLangOptions + entrypoints + sourceDirs + let cs = flip map q $ \(cn, (opts, (srcOpts, (langOpts, (ep, srcDirs))))) -> + GmComponent cn opts srcOpts langOpts ep ep srcDirs mempty return ([setupConfigPath], cs) } where - join4 a b c = join' a . join' b . join' c + join5 a b c d = join' a . join' b . join' c . join' d join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))] join' lb lc = [ (a, (b, c)) | (a, b) <- lb diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 14c04bc..32938d6 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -180,6 +180,9 @@ setupConfigFile crdl = cradleRootDir crdl setupConfigPath setupConfigPath :: FilePath setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref +macrosHeaderPath :: FilePath +macrosHeaderPath = "dist/build/autogen/cabal_macros.h" + ghcSandboxPkgDbDir :: String ghcSandboxPkgDbDir = cabalBuildPlatform ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d" diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 6231683..f3712a3 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -260,18 +260,26 @@ resolveGmComponent :: (IOish m, GmLog m, GmEnv m) -> GmComponent GMCRaw (Set ModulePath) -> m (GmComponent GMCResolved (Set ModulePath)) resolveGmComponent mums c@GmComponent {..} = do - withLightHscEnv gmcGhcSrcOpts $ \env -> do + withLightHscEnv ghcOpts $ \env -> do let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs let mg = gmcHomeModuleGraph let simp = gmcEntrypoints sump <- case mums of Nothing -> return simp - Just ums -> Set.fromList . catMaybes <$> mapM (resolveModule env srcDirs) ums + Just ums -> + Set.fromList . catMaybes <$> + mapM (resolveModule env srcDirs) ums mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' } + where ghcOpts = concat [ + gmcGhcSrcOpts, + gmcGhcLangOpts, + [ "-optP-include", "-optP" ++ macrosHeaderPath ] + ] + resolveEntrypoint :: IOish m => Cradle -> GmComponent GMCRaw ChEntrypoint diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index fcc0199..f7340d0 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -164,7 +164,6 @@ type ModuleString = String -- | A Module type Module = [String] - data GmLogLevel = GmPanic | GmException | GmError @@ -215,6 +214,7 @@ data GmComponent (t :: GmComponentType) eps = GmComponent { gmcName :: ChComponentName, gmcGhcOpts :: [GHCOption], gmcGhcSrcOpts :: [GHCOption], + gmcGhcLangOpts :: [GHCOption], gmcRawEntrypoints :: ChEntrypoint, gmcEntrypoints :: eps, gmcSourceDirs :: [FilePath], diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 9fc8b57..2c15b66 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -121,7 +121,7 @@ Library , bytestring , cereal >= 0.4 , containers - , cabal-helper >= 0.3.1.0 + , cabal-helper >= 0.3.2.0 , deepseq , directory , filepath From 39a8ded102bcc33d8bbfd1d9253f2954431c5400 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 12 Apr 2015 02:39:18 +0200 Subject: [PATCH 064/207] Fix resolved component caching --- Language/Haskell/GhcMod/CabalHelper.hs | 2 +- Language/Haskell/GhcMod/Caching.hs | 17 +++++++++-------- Language/Haskell/GhcMod/Target.hs | 26 +++++++++++++++++++------- 3 files changed, 29 insertions(+), 16 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index ed0bc5c..b229a2a 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -74,7 +74,7 @@ cabalHelperCache :: MonadIO m => Cached m [GmComponent GMCRaw ChEntrypoint] cabalHelperCache = Cached { cacheFile = cabalHelperCacheFile, - cachedAction = \ _ (progs, root, _) -> + cachedAction = \ _ (progs, root, _) _ -> runQuery' progs root $ do q <- liftM5 join5 ghcOptions diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs index db07af4..54892c9 100644 --- a/Language/Haskell/GhcMod/Caching.hs +++ b/Language/Haskell/GhcMod/Caching.hs @@ -5,6 +5,7 @@ import Data.Maybe import Data.Serialize import qualified Data.ByteString as BS import System.FilePath +import Utils (TimedFile(..), timeMaybe, mightExist) import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Logging @@ -13,7 +14,7 @@ import Utils data Cached m d a = Cached { cacheFile :: FilePath, - cachedAction :: TimedCacheFiles -> d -> m ([FilePath], a) + cachedAction :: TimedCacheFiles -> d -> Maybe a -> m ([FilePath], a) -- ^ The cached action, will only run if -- * The cache doesn\'t exist yet -- * The cache exists and 'inputData' changed @@ -37,21 +38,21 @@ cached dir cd d = do let defTcf = TimedCacheFiles tcfile [] case mcc of - Nothing -> writeCache defTcf "cache missing" - Just (ifs, d', _) | d /= d' -> do + Nothing -> writeCache defTcf Nothing "cache missing" + Just (ifs, d', a) | d /= d' -> do tcf <- timeCacheInput dir (cacheFile cd) ifs - writeCache tcf "input data changed" + writeCache tcf (Just a) "input data changed" Just (ifs, _, a) -> do tcf <- timeCacheInput dir (cacheFile cd) ifs let invifs = invalidatingInputFiles tcf case invifs of - Nothing -> writeCache tcf "cache missing, existed a sec ago WTF?" + Nothing -> writeCache tcf (Just a) "cache missing, existed a sec ago WTF?" Just [] -> return a - Just _ -> writeCache tcf "input files changed" + Just _ -> writeCache tcf (Just a) "input files changed" where - writeCache tcf cause = do - (ifs', a) <- (cachedAction cd) tcf d + writeCache tcf ma cause = do + (ifs', a) <- (cachedAction cd) tcf d ma gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) <+> parens (text cause) liftIO $ BS.writeFile (dir cacheFile cd) $ encode (ifs', d, a) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index f3712a3..06ebf28 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -191,17 +191,29 @@ targetGhcOptions crdl sefnmn = do return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs resolvedComponentsCache :: IOish m => Cached (GhcModT m) - [GmComponent GMCRaw(Set.Set ModulePath)] + [GmComponent GMCRaw (Set.Set ModulePath)] (Map.Map ChComponentName (GmComponent GMCResolved (Set.Set ModulePath))) resolvedComponentsCache = Cached { cacheFile = resolvedComponentsCacheFile, - cachedAction = \tcfs comps -> do + cachedAction = \tcfs comps ma -> do Cradle {..} <- cradle - let changedFiles = - filter (/= cradleRootDir setupConfigPath) $ map tfPath $ tcFiles tcfs - mums = if null changedFiles - then Nothing - else Just $ map Left changedFiles + let mums = + case invalidatingInputFiles tcfs of + Nothing -> Nothing + Just iifs -> + let + filterOutSetupCfg = + filter (/= cradleRootDir setupConfigPath) + changedFiles = filterOutSetupCfg iifs + in if null changedFiles + then Nothing + else Just $ map Left changedFiles + + case ma of + Just mcs -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs } + Nothing -> return () + +-- liftIO $ print ("changed files", mums :: Maybe [Either FilePath ()]) mcs <- resolveGmComponents mums comps return (setupConfigPath:flatten mcs , mcs) From 2bf4c80580c83d5331d384af9ce545a419c1c1a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 12 Apr 2015 02:40:39 +0200 Subject: [PATCH 065/207] Fix finding consistent component solution for targets Union does the wrong thing, I wanted an intersection here. --- Language/Haskell/GhcMod/Target.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 06ebf28..c5aa824 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -174,7 +174,7 @@ targetGhcOptions crdl sefnmn = do mcs <- cached cradleRootDir resolvedComponentsCache comps let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn - candidates = Set.unions $ map snd mdlcs + candidates = findCandidates $ map snd mdlcs let noCandidates = Set.null candidates noModuleHasAnyAssignment = all (Set.null . snd) mdlcs @@ -249,6 +249,11 @@ moduleComponents m efnmn = foldr' b as f = Map.foldr f b as + +findCandidates :: [Set ChComponentName] -> Set ChComponentName +findCandidates [] = Set.empty +findCandidates scns = foldl1 Set.intersection scns + pickComponent :: Set ChComponentName -> ChComponentName pickComponent scn = Set.findMin scn From d7984faf79802139f0e7a249a54c2ee8a53fa318 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 12 Apr 2015 02:41:57 +0200 Subject: [PATCH 066/207] No double `:` in logmsgs without a location --- Language/Haskell/GhcMod/Logging.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index f028a28..f980635 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -60,8 +60,8 @@ gmLog level loc' doc = do GhcModLog { gmLogLevel = level' } <- gmlHistory let loc | loc' == "" = empty - | otherwise = text loc' - msg = gmRenderDoc $ (gmLogLevelDoc level <+>: loc) <+>: doc + | otherwise = empty <+>: text loc' + msg = gmRenderDoc $ (gmLogLevelDoc level <> loc) <+>: doc msg' = dropWhileEnd isSpace msg when (Just level <= level') $ From ee4ee8765e5c5ce34e001c04b4ec52d3423bf221 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 12 Apr 2015 02:46:08 +0200 Subject: [PATCH 067/207] Fix weird `resolveModule` double path issue `mconcat` recurses into `Maybe a` which is not what I want, I just want the first `Just` value --- Language/Haskell/GhcMod/Target.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index c5aa824..07199a6 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -40,6 +40,7 @@ import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Data.Maybe +import Data.Monoid import Data.Either import Data.Foldable (foldrM) import Data.IORef @@ -327,7 +328,7 @@ resolveModule env srcDirs (Left fn') = liftIO $ do Just mn -> ModulePath mn fn where findFile' dirs file = - mconcat <$> mapM (mightExist . (file)) dirs + getFirst . mconcat <$> mapM (fmap First . mightExist . (file)) dirs resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [Either FilePath ModuleName] From 94ef8fae79358409673cf96e1c9b02b4ce0f57eb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 12 Apr 2015 02:48:05 +0200 Subject: [PATCH 068/207] Enhance debug information --- Language/Haskell/GhcMod/Debug.hs | 31 +++++++++++++++++++++++++++---- 1 file changed, 27 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 23a902b..907b035 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -57,12 +57,27 @@ cabalDebug = do componentInfo :: IOish m => [String] -> GhcModT m String componentInfo ts = do + -- TODO: most of this is copypasta of targetGhcOptions. Factor out more + -- useful function from there. crdl <- cradle - opts <- targetGhcOptions crdl $ Set.fromList $ map guessModuleFile ts + let sefnmn = Set.fromList $ map guessModuleFile ts + comps <- mapM (resolveEntrypoint crdl) =<< getComponents + mcs <- resolveGmComponents Nothing comps + let + mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn + candidates = findCandidates $ map snd mdlcs + cn = pickComponent candidates + opts <- targetGhcOptions crdl sefnmn return $ unlines $ - [ "GHC Cabal options:\n" ++ render (nest 4 $ fsep $ map text opts) + [ "Matching Components:\n" ++ render (nest 4 $ + alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs) + , "Picked Component:\n" ++ render (nest 4 $ + gmComponentNameDoc cn) + , "GHC Cabal options:\n" ++ render (nest 4 $ fsep $ map text opts) ] + where + zipMap f l = l `zip` (f `map` l) guessModuleFile :: String -> Either FilePath ModuleName guessModuleFile mn@(h:r) @@ -71,17 +86,25 @@ guessModuleFile str = Left str graphDoc :: GmModuleGraph -> Doc graphDoc GmModuleGraph{..} = - mapDoc mpDoc' smpDoc' gmgGraph + mapDoc mpDoc smpDoc' gmgGraph where smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp mpDoc' = text . moduleNameString . mpModule +setDoc :: (a -> Doc) -> Set.Set a -> Doc +setDoc f s = vcat $ map f $ Set.toList s + smpDoc :: Set.Set ModulePath -> Doc -smpDoc smp = vcat $ map mpDoc $ Set.toList smp +smpDoc smp = setDoc mpDoc smp mpDoc :: ModulePath -> Doc mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn) +mnDoc :: ModuleName -> Doc +mnDoc mn = text (moduleNameString mn) + +alistDoc :: Ord k => (k -> Doc) -> (a -> Doc) -> [(k, a)] -> Doc +alistDoc fk fa alist = mapDoc fk fa (Map.fromList alist) mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc mapDoc kd ad m = vcat $ From 9077e96aeb6760f0157b0cc4a91a619f08b04d4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 12 Apr 2015 03:03:37 +0200 Subject: [PATCH 069/207] Fix tests --- Language/Haskell/GhcMod/Caching.hs | 2 -- Language/Haskell/GhcMod/HomeModuleGraph.hs | 3 +-- Language/Haskell/GhcMod/Target.hs | 1 + Language/Haskell/GhcMod/Types.hs | 1 - test/HomeModuleGraphSpec.hs | 4 +--- 5 files changed, 3 insertions(+), 8 deletions(-) diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs index 54892c9..71067f9 100644 --- a/Language/Haskell/GhcMod/Caching.hs +++ b/Language/Haskell/GhcMod/Caching.hs @@ -10,8 +10,6 @@ import Utils (TimedFile(..), timeMaybe, mightExist) import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Logging -import Utils - data Cached m d a = Cached { cacheFile :: FilePath, cachedAction :: TimedCacheFiles -> d -> Maybe a -> m ([FilePath], a) diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index f42c6db..12badf2 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -48,7 +48,6 @@ import Control.Monad.State.Strict (execStateT) import Control.Monad.State.Class import Data.Maybe import Data.Monoid -import Data.Traversable as T (mapM) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -58,7 +57,6 @@ import System.Directory import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Logger -import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Gap (parseModuleHeader) @@ -150,6 +148,7 @@ find env mn = liftIO $ do _ -> return Nothing +canonicalizeModulePath :: ModulePath -> IO ModulePath canonicalizeModulePath (ModulePath mn fp) = ModulePath mn <$> canonicalizePath fp canonicalizeModuleGraph :: MonadIO m => GmModuleGraph -> m GmModuleGraph diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 07199a6..ef668f7 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -43,6 +43,7 @@ import Data.Maybe import Data.Monoid import Data.Either import Data.Foldable (foldrM) +import Data.Traversable (traverse) import Data.IORef import Data.Map (Map) import qualified Data.Map as Map diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index f7340d0..dbbee80 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -13,7 +13,6 @@ import Control.Monad.Error (Error(..)) import qualified Control.Monad.IO.Class as MTL import Control.Exception (Exception) import Control.Applicative -import Control.Arrow import Data.Serialize import Data.Version import Data.List (intercalate) diff --git a/test/HomeModuleGraphSpec.hs b/test/HomeModuleGraphSpec.hs index b4640d1..7e43140 100644 --- a/test/HomeModuleGraphSpec.hs +++ b/test/HomeModuleGraphSpec.hs @@ -72,7 +72,7 @@ spec = do , mp "H" , mp "I" ] - fileMap = mkFileMap smp + moduleMap = mkModuleMap smp completeGraph = @@ -104,8 +104,6 @@ spec = do ] g = GmModuleGraph { - gmgFileMap = fileMap, - gmgModuleMap = moduleMap, gmgGraph = graph } From 95b16ded6d80b494363336ad43d9ae5901ae173f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 14 Apr 2015 00:51:03 +0200 Subject: [PATCH 070/207] Fix `checkComponent` --- Language/Haskell/GhcMod/Debug.hs | 22 ++++++++++++++++------ Language/Haskell/GhcMod/Utils.hs | 7 +++++++ 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 907b035..e7d56de 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -1,10 +1,12 @@ module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where import Control.Arrow (first) -import Control.Applicative ((<$>)) +import Control.Applicative +import Control.Monad import qualified Data.Map as Map import qualified Data.Set as Set import Data.Char +import Data.List.Split import Text.PrettyPrint import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad @@ -13,6 +15,7 @@ import Language.Haskell.GhcMod.Internal import Language.Haskell.GhcMod.CabalHelper import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Pretty +import Language.Haskell.GhcMod.Utils ---------------------------------------------------------------- @@ -60,7 +63,7 @@ componentInfo ts = do -- TODO: most of this is copypasta of targetGhcOptions. Factor out more -- useful function from there. crdl <- cradle - let sefnmn = Set.fromList $ map guessModuleFile ts + sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts comps <- mapM (resolveEntrypoint crdl) =<< getComponents mcs <- resolveGmComponents Nothing comps let @@ -79,10 +82,17 @@ componentInfo ts = do where zipMap f l = l `zip` (f `map` l) -guessModuleFile :: String -> Either FilePath ModuleName -guessModuleFile mn@(h:r) - | isUpper h && all isAlphaNum r = Right $ mkModuleName mn -guessModuleFile str = Left str +guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName) +guessModuleFile m + | (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m = + return $ Right $ mkModuleName m + where + infixr 1 .||. + infixr 2 .&&. + (.||.) = liftA2 (||) + (.&&.) = liftA2 (&&) + +guessModuleFile str = Left `liftM` liftIO (canonFilePath str) graphDoc :: GmModuleGraph -> Doc graphDoc GmModuleGraph{..} = diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index c39037b..0ff4c22 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -34,6 +34,7 @@ import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators, ()) import System.IO.Temp (createTempDirectory) import System.Environment +import System.Directory import Text.Printf import Paths_ghc_mod (getLibexecDir) @@ -159,3 +160,9 @@ getExecutablePath' = getExecutablePath #else getExecutablePath' = getProgName #endif + +canonFilePath f = do + p <- canonicalizePath f + e <- doesFileExist p + when (not e) $ error $ "canonFilePath: not a file: " ++ p + return p From fb19d021ca76fc5ada37cba94c051be3379372ec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 14 Apr 2015 21:39:11 +0200 Subject: [PATCH 071/207] Fix a few warnings --- Language/Haskell/GhcMod/Utils.hs | 7 ++++--- ghc-mod.cabal | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 0ff4c22..91331b5 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -27,14 +27,14 @@ import Data.Char import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Monad.Types import Exception -import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist) +import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist, + getTemporaryDirectory, canonicalizePath, doesFileExist) import System.Process (readProcess) -import System.Directory (getTemporaryDirectory) +import System.Directory () import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators, ()) import System.IO.Temp (createTempDirectory) import System.Environment -import System.Directory import Text.Printf import Paths_ghc_mod (getLibexecDir) @@ -161,6 +161,7 @@ getExecutablePath' = getExecutablePath getExecutablePath' = getProgName #endif +canonFilePath :: FilePath -> IO FilePath canonFilePath f = do p <- canonicalizePath f e <- doesFileExist p diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 2c15b66..3743948 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -28,7 +28,7 @@ Cabal-Version: >= 1.14 Build-Type: Custom Data-Files: elisp/Makefile elisp/*.el - +Data-Files: LICENSE COPYING.BSD3 COPYING.AGPL3 Extra-Source-Files: ChangeLog SetupCompat.hs NotCPP/*.hs From c7efeacd784d7299f9c3c26e018b567bb67ba003 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 15 Apr 2015 13:13:00 +0200 Subject: [PATCH 072/207] Fix X-Install-Target for older Cabal versions --- Setup.hs | 45 ++++++++++++++++++++++++++++++++++----------- 1 file changed, 34 insertions(+), 11 deletions(-) diff --git a/Setup.hs b/Setup.hs index b44e529..982ec70 100755 --- a/Setup.hs +++ b/Setup.hs @@ -3,6 +3,7 @@ import Distribution.Simple import Distribution.Simple.Setup import Distribution.Simple.Install +import Distribution.Simple.Register import Distribution.Simple.InstallDirs as ID import Distribution.Simple.LocalBuildInfo import Distribution.PackageDescription @@ -26,10 +27,8 @@ main = defaultMainWithHooks $ simpleUserHooks { confHook = \(gpd, hbi) cf -> xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf - , copyHook = xInstallTargetHook - - , instHook = \pd lbi uh ifl -> - (instHook simpleUserHooks) pd lbi uh ifl + , instHook = inst + , copyHook = copy -- , postConf = sanityCheckCabalVersions } @@ -60,14 +59,38 @@ xBuildDependsLike lbi = where fields = customFieldsBI (componentBuildInfo comp) -xInstallTargetHook :: - PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () -xInstallTargetHook pd lbi uh cf = do +-- mostly copypasta from 'defaultInstallHook' +inst :: + PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () +inst pd lbi _uf ifl = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref ifl, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity ifl + } + xInstallTarget pd lbi (\pd' lbi' -> install pd' lbi' copyFlags) + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref ifl, + regInPlace = installInPlace ifl, + regPackageDB = installPackageDB ifl, + regVerbosity = installVerbosity ifl + } + when (hasLibs pd) $ register pd lbi registerFlags + +copy :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () +copy pd lbi _uh cf = + xInstallTarget pd lbi (\pd' lbi' -> install pd' lbi' cf) + +xInstallTarget :: PackageDescription + -> LocalBuildInfo + -> (PackageDescription -> LocalBuildInfo -> IO ()) + -> IO () +xInstallTarget pd lbi fn = do let (extended, regular) = partition (isJust . installTarget) (executables pd) let pd_regular = pd { executables = regular } - flip mapM extended $ \exe -> do + _ <- flip mapM extended $ \exe -> do putStrLn $ "extended " ++ show (exeName exe) let @@ -87,10 +110,9 @@ xInstallTargetHook pd lbi uh cf = do bindir = install_target'' } } + fn pd_extended lbi' - install pd_extended lbi' cf - - install pd_regular lbi cf + fn pd_regular lbi where installTarget :: Executable -> Maybe PathTemplate @@ -108,6 +130,7 @@ xInstallTargetHook pd lbi uh cf = do withPT f pt = toPathTemplate $ f (fromPathTemplate pt) withSP f p = joinPath $ f (splitPath p) +onlyExePackageDesc :: [Executable] -> PackageDescription -> PackageDescription onlyExePackageDesc exes pd = emptyPackageDescription { package = package pd , executables = exes From 247e4e0e7616fe1fecc68fdcf80d6249ac4cee4f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 15 Apr 2015 13:13:22 +0200 Subject: [PATCH 073/207] Decrease default log level --- Language/Haskell/GhcMod/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index dbbee80..54a1c44 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -89,7 +89,7 @@ defaultOptions :: Options defaultOptions = Options { outputStyle = PlainStyle , lineSeparator = LineSeparator "\0" - , logLevel = GmInfo + , logLevel = GmWarning , ghcProgram = "ghc" , ghcPkgProgram = "ghc-pkg" , cabalProgram = "cabal" From 5d9d6f5630902ea4181fbb121e6729092ef67fea Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Tue, 3 Mar 2015 12:18:54 +0100 Subject: [PATCH 074/207] Custom cradle support --- Language/Haskell/GhcMod/CabalHelper.hs | 10 +++++-- Language/Haskell/GhcMod/Cradle.hs | 35 +++++++++++++++++++++++- Language/Haskell/GhcMod/PathsAndFiles.hs | 11 +++++++- Language/Haskell/GhcMod/Types.hs | 2 +- README.md | 13 +++++++++ test/CradleSpec.hs | 7 +++++ test/data/custom-cradle/.ghc-mod.cradle | 5 ++++ test/data/custom-cradle/dummy.cabal | 1 + 8 files changed, 79 insertions(+), 5 deletions(-) create mode 100644 test/data/custom-cradle/.ghc-mod.cradle create mode 100644 test/data/custom-cradle/dummy.cabal diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index b229a2a..1ea7a55 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -95,20 +95,26 @@ cabalHelperCache = Cached { , a == a' ] - withCabal :: (MonadIO m, GmEnv m) => m a -> m a withCabal action = do crdl <- cradle opts <- options liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $ withDirectory_ (cradleRootDir crdl) $ do - let progOpts = + let pkgDbArgs = "--package-db=clear" : map pkgDbArg (cradlePkgDbStack crdl) + progOpts = [ "--with-ghc=" ++ T.ghcProgram opts ] -- Only pass ghc-pkg if it was actually set otherwise we -- might break cabal's guessing logic ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ] else [] + ++ pkgDbArgs void $ readProcess (T.cabalProgram opts) ("configure":progOpts) "" writeAutogenFiles $ cradleRootDir crdl "dist" action + +pkgDbArg :: GhcPkgDb -> String +pkgDbArg GlobalDb = "--package-db=global" +pkgDbArg UserDb = "--package-db=user" +pkgDbArg (PackageDb p) = "--package-db=" ++ p diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index 8aca44a..e0a691a 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -28,7 +28,7 @@ findCradle = findCradle' =<< getCurrentDirectory findCradle' :: FilePath -> IO Cradle findCradle' dir = run $ do - (cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir) + (customCradle dir `mplus` cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir) where run a = fillTempDir =<< (fromJust <$> runMaybeT a) findSpecCradle :: FilePath -> IO Cradle @@ -52,6 +52,21 @@ fillTempDir crdl = do tmpDir <- liftIO $ newTempDir (cradleRootDir crdl) return crdl { cradleTempDir = tmpDir } +customCradle :: FilePath -> MaybeT IO Cradle +customCradle wdir = do + cabalFile <- MaybeT $ findCabalFile wdir + let cabalDir = takeDirectory cabalFile + cradleFile <- MaybeT $ findCradleFile cabalDir + tmpDir <- liftIO $ newTempDir cabalDir + pkgDbStack <- liftIO $ parseCradle cradleFile + return Cradle { + cradleCurrentDir = wdir + , cradleRootDir = cabalDir + , cradleTempDir = tmpDir + , cradleCabalFile = Just cabalFile + , cradlePkgDbStack = pkgDbStack + } + cabalCradle :: FilePath -> MaybeT IO Cradle cabalCradle wdir = do cabalFile <- MaybeT $ findCabalFile wdir @@ -95,3 +110,21 @@ getPackageDbStack :: FilePath -- ^ Project Directory (where the -> IO [GhcPkgDb] getPackageDbStack cdir = ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir + +-- Just for testing +findCradleWithoutSandbox :: IO Cradle +findCradleWithoutSandbox = do + cradle <- findCradle + return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME + + +parseCradle :: FilePath -> IO [GhcPkgDb] +parseCradle path = do + source <- readFile path + return $ parseCradle' source + where + parseCradle' source = map parsePkgDb $ filter (not . null) $ lines source + + parsePkgDb "global" = GlobalDb + parsePkgDb "user" = UserDb + parsePkgDb s = PackageDb s diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 32938d6..00ad384 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -193,7 +193,6 @@ cabalBuildPlatform = unsafePerformIO $ buildPlatform packageCache :: String packageCache = "package.cache" - -- | Filename of the symbol table cache file. symbolCache :: Cradle -> FilePath symbolCache crdl = cradleTempDir crdl symbolCacheFile @@ -206,3 +205,13 @@ resolvedComponentsCacheFile = setupConfigPath <.> "ghc-mod.resolved-components" cabalHelperCacheFile :: String cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-helper" + +-- | @findCradleFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@. +-- If it exists in the given directory it is returned otherwise @findCradleFile@ returns @Nothing@ +findCradleFile :: FilePath -> IO (Maybe FilePath) +findCradleFile directory = do + let path = directory "ghc-mod.cradle" + exists <- doesFileExist $ path + case exists of + True -> return $ Just path + False -> return Nothing diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 54a1c44..84385a1 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -272,7 +272,7 @@ data GhcModError | GMECabalStateFile GMConfigStateFileError -- ^ Reading Cabal's state configuration file falied somehow. - deriving (Eq,Show,Typeable) + deriving (Eq,Show,Typeable) instance Error GhcModError where noMsg = GMENoMsg diff --git a/README.md b/README.md index 2065673..74aa472 100644 --- a/README.md +++ b/README.md @@ -44,6 +44,19 @@ Make sure you're not using the MELPA version of `ghc.el` otherwise you might get all sorts of nasty conflicts. +## Custom ghc-mod cradle + +To customize the package databases used by `ghc-mod`, put a file called `.ghc-mod.cradle` beside the `.cabal` file with the following syntax: + +``` +temp directory root +package db 1 +... +package db n +``` + +each package database line is either a *path* to a package database, or `global` or `user`. + ## IRC If you have any problems, suggestions, comments swing by diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index f39f277..8e7f733 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -71,4 +71,11 @@ spec = do cradleCabalFile res `shouldBe` Just ("test" "data" "broken-sandbox" "dummy.cabal") + it "uses the custom cradle file if present" $ do + withDirectory "test/data/custom-cradle" $ \dir -> do + res <- relativeCradle dir <$> findCradle + cradleCurrentDir res `shouldBe` "test" "data" "custom-cradle" + cradleRootDir res `shouldBe` "test" "data" "custom-cradle" + cradleCabalFile res `shouldBe` Just ("test" "data" "custom-cradle" "dummy.cabal") + cradlePkgDbStack res `shouldBe` [PackageDb "a/packages", GlobalDb, PackageDb "b/packages", UserDb, PackageDb "c/packages"] cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb] diff --git a/test/data/custom-cradle/.ghc-mod.cradle b/test/data/custom-cradle/.ghc-mod.cradle new file mode 100644 index 0000000..38259f1 --- /dev/null +++ b/test/data/custom-cradle/.ghc-mod.cradle @@ -0,0 +1,5 @@ +a/packages +global +b/packages +user +c/packages diff --git a/test/data/custom-cradle/dummy.cabal b/test/data/custom-cradle/dummy.cabal new file mode 100644 index 0000000..421376d --- /dev/null +++ b/test/data/custom-cradle/dummy.cabal @@ -0,0 +1 @@ +dummy From 308c2d7963f2865026175e5d76ce5a442f4f4163 Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Thu, 23 Apr 2015 17:31:54 +0200 Subject: [PATCH 075/207] Undo indenation change in Types.hs --- Language/Haskell/GhcMod/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 84385a1..54a1c44 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -272,7 +272,7 @@ data GhcModError | GMECabalStateFile GMConfigStateFileError -- ^ Reading Cabal's state configuration file falied somehow. - deriving (Eq,Show,Typeable) + deriving (Eq,Show,Typeable) instance Error GhcModError where noMsg = GMENoMsg From 3b7d51d25a75335d5614a030472713c28e86676f Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Fri, 24 Apr 2015 10:41:39 +0200 Subject: [PATCH 076/207] Removed unused function --- Language/Haskell/GhcMod/Cradle.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index e0a691a..7784631 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -111,13 +111,6 @@ getPackageDbStack :: FilePath -- ^ Project Directory (where the getPackageDbStack cdir = ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir --- Just for testing -findCradleWithoutSandbox :: IO Cradle -findCradleWithoutSandbox = do - cradle <- findCradle - return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME - - parseCradle :: FilePath -> IO [GhcPkgDb] parseCradle path = do source <- readFile path From 84888627af04ccd45e34ff96d13363868c9795b1 Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Sun, 26 Apr 2015 17:33:01 +0200 Subject: [PATCH 077/207] Fixed custom cradle test --- test/CradleSpec.hs | 3 ++- test/data/custom-cradle/{.ghc-mod.cradle => ghc-mod.cradle} | 0 2 files changed, 2 insertions(+), 1 deletion(-) rename test/data/custom-cradle/{.ghc-mod.cradle => ghc-mod.cradle} (100%) diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index 8e7f733..97fc81d 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -71,6 +71,8 @@ spec = do cradleCabalFile res `shouldBe` Just ("test" "data" "broken-sandbox" "dummy.cabal") + cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb] + it "uses the custom cradle file if present" $ do withDirectory "test/data/custom-cradle" $ \dir -> do res <- relativeCradle dir <$> findCradle @@ -78,4 +80,3 @@ spec = do cradleRootDir res `shouldBe` "test" "data" "custom-cradle" cradleCabalFile res `shouldBe` Just ("test" "data" "custom-cradle" "dummy.cabal") cradlePkgDbStack res `shouldBe` [PackageDb "a/packages", GlobalDb, PackageDb "b/packages", UserDb, PackageDb "c/packages"] - cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb] diff --git a/test/data/custom-cradle/.ghc-mod.cradle b/test/data/custom-cradle/ghc-mod.cradle similarity index 100% rename from test/data/custom-cradle/.ghc-mod.cradle rename to test/data/custom-cradle/ghc-mod.cradle From 192fc220ccab980881000b8bc36ca29be3469d83 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 29 Apr 2015 01:22:37 +0200 Subject: [PATCH 078/207] Fix some tests --- .travis.yml | 1 - ghc-mod.cabal | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 1322045..e8fd54e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -26,7 +26,6 @@ script: - if [ -n "$(ghc --version | awk '{ print $8 }' | sed -n '/^7.8/p')" ]; then export WERROR="--ghc-option=-Werror"; fi - cabal configure --enable-tests $WERROR - cabal build - - export cabal_helper_libexecdir=$HOME/.cabal/bin - export ghc_mod_datadir=$PWD - cabal test diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 3743948..5879f66 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -121,7 +121,7 @@ Library , bytestring , cereal >= 0.4 , containers - , cabal-helper >= 0.3.2.0 + , cabal-helper >= 0.3.3.0 , deepseq , directory , filepath From ea03f8a935d82cfd4a5af58dd5be5ef6e4741dcc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 29 Apr 2015 10:10:18 +0200 Subject: [PATCH 079/207] Fix tests for 7.8 --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index e8fd54e..9c9d3bc 100644 --- a/.travis.yml +++ b/.travis.yml @@ -10,7 +10,7 @@ install: # - ( $CABAL122 && cabal install cabal-install --constraint "Cabal >= 1.22" && ghc-pkg unregister Cabal ) || true - echo $PATH - which cabal -# - cabal install Cabal --constraint "Cabal == $(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | tail -n1)" + - if [ -n "$(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | tail -n1 | sed -n '/^1.18/p')" ]; then cabal install cabal-install --constraint "Cabal == 1.18.* && > 1.18.0"; fi - cabal install happy - happy --version - cabal install -j --only-dependencies --enable-tests --constraint "tagged < 0.8" From 6759c59a01b171748457dac9cfb7bb5078b5d2cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 29 Apr 2015 17:13:13 +0200 Subject: [PATCH 080/207] tagged was fixed --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 9c9d3bc..662cf7b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -13,7 +13,7 @@ install: - if [ -n "$(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | tail -n1 | sed -n '/^1.18/p')" ]; then cabal install cabal-install --constraint "Cabal == 1.18.* && > 1.18.0"; fi - cabal install happy - happy --version - - cabal install -j --only-dependencies --enable-tests --constraint "tagged < 0.8" + - cabal install -j --only-dependencies --enable-tests script: - touch ChangeLog # Create ChangeLog if we're not on the release branch From c8313321852c0e23d906ad55de1e414c2f56843b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 29 Apr 2015 17:21:37 +0200 Subject: [PATCH 081/207] Set -O0 to avoid various interperter issues --- Language/Haskell/GhcMod/Target.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index ef668f7..8c2da37 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -146,7 +146,7 @@ runGmlTWith efnmns' mdf wrapper action = do cfns <- liftIO $ mapM canonicalizePath ccfns let serfnmn = Set.fromList $ map Right mns ++ map Left cfns opts <- targetGhcOptions crdl serfnmn - let opts' = opts ++ ghcUserOptions + let opts' = opts ++ ["-O0"] ++ ghcUserOptions initSession opts' $ setModeSimple >>> setEmptyLogger >>> mdf From cf5dfa439c38bcd3e9e1e8ca947a6187802ceccc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 29 Apr 2015 17:22:48 +0200 Subject: [PATCH 082/207] Clarify HscInterpreted log message --- Language/Haskell/GhcMod/Target.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 8c2da37..fb20c97 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -396,7 +396,7 @@ loadTargets filesOrModules = do resetTargets targets setIntelligent gmLog GmInfo "loadTargets" $ - text "Switching to LinkInMemory/HscInterpreted (memory hungry)" + text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms." loadTargets' Intelligent else loadTargets' Simple From 503562b9b6b49a327884ab595ff66b99c6557e62 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 29 Apr 2015 18:41:28 +0200 Subject: [PATCH 083/207] Fix typo succ -> pred --- Language/Haskell/GhcMod/Logging.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index f980635..37684a5 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -46,7 +46,7 @@ increaseLogLevel l = succ l decreaseLogLevel :: GmLogLevel -> GmLogLevel decreaseLogLevel l | l == minBound = l -decreaseLogLevel l = succ l +decreaseLogLevel l = pred l -- | -- >>> Just GmDebug <= Nothing From 8b8f947b5ea05d53cbed1f1594c82041da065d26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 29 Apr 2015 18:44:21 +0200 Subject: [PATCH 084/207] Reinitialize GHC session when options change --- Language/Haskell/GhcMod/Target.hs | 49 +++++++++++++++---------------- 1 file changed, 24 insertions(+), 25 deletions(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index fb20c97..790a581 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -92,34 +92,33 @@ initSession :: IOish m initSession opts mdf = do s <- gmsGet case gmGhcSession s of - Just GmGhcSession {..} -> do - if gmgsOptions == opts - then return () - else error "TODO: reload stuff" - Nothing -> do - Cradle { cradleTempDir } <- cradle - ghc <- liftIO $ runGhc (Just libdir) $ do - let setDf df = - setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df) - _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags - getSession + Just GmGhcSession {..} -> when (gmgsOptions /= opts) $ putNewSession s + Nothing -> putNewSession s - rghc <- liftIO $ newIORef ghc - gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc } + where + putNewSession s = do + rghc <- (liftIO . newIORef =<< newSession =<< cradle) + gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc } + + newSession Cradle { cradleTempDir } = liftIO $ do + runGhc (Just libdir) $ do + let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df) + _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags + getSession + +dropSession :: IOish m => GhcModT m () +dropSession = do + s <- gmsGet + case gmGhcSession s of + Just (GmGhcSession _opts ref) -> do + -- TODO: This is still not enough, there seem to still be references to + -- GHC's state around afterwards. + liftIO $ writeIORef ref (error "HscEnv: session was dropped") + liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped") --- $ do --- dflags <- getSessionDynFlags --- defaultCleanupHandler dflags $ do --- initializeFlagsWithCradle opt (gmCradle env) --- - --- initSession :: GhcMonad m => Options -> [GHCOption] -> m () --- initSession Options {..} ghcOpts = do --- df <- G.getSessionDynFlags --- void $ --- ( setModeSimple -- $ setEmptyLogger --- df) + Nothing -> return () + gmsPut s { gmGhcSession = Nothing } runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a runGmlT fns action = runGmlT' fns return action From c45a7f4b524e1b05fc6b7e70f0bbda6388a92eba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 5 May 2015 14:44:42 +0200 Subject: [PATCH 085/207] Fix caching for getGhcPkgOptions --- Language/Haskell/GhcMod/CabalHelper.hs | 32 +++++++++++++++----------- Language/Haskell/GhcMod/Modules.hs | 2 +- Language/Haskell/GhcMod/Target.hs | 4 ++-- Language/Haskell/GhcMod/Types.hs | 5 ++-- 4 files changed, 24 insertions(+), 19 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index b229a2a..7c6de37 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -38,11 +38,9 @@ import Paths_ghc_mod as GhcMod -- | Only package related GHC options, sufficient for things that don't need to -- access home modules -getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(ChComponentName, [GHCOption])] -getGhcPkgOptions = do - Cradle {..} <- cradle - let distdir = cradleRootDir "dist" - runQuery distdir ghcPkgOptions +getGhcPkgOptions :: (MonadIO m, GmEnv m, GmLog m) + => m [(ChComponentName, [GHCOption])] +getGhcPkgOptions = map (\c -> (gmcName c, gmcGhcPkgOpts c)) `liftM` getComponents helperProgs :: Options -> Programs helperProgs opts = Programs { @@ -76,25 +74,31 @@ cabalHelperCache = Cached { cacheFile = cabalHelperCacheFile, cachedAction = \ _ (progs, root, _) _ -> runQuery' progs root $ do - q <- liftM5 join5 + q <- liftM7 join7 ghcOptions + ghcPkgOptions ghcSrcOptions ghcLangOptions entrypoints + entrypoints sourceDirs - let cs = flip map q $ \(cn, (opts, (srcOpts, (langOpts, (ep, srcDirs))))) -> - GmComponent cn opts srcOpts langOpts ep ep srcDirs mempty + let cs = flip map q $ curry8 (GmComponent mempty) return ([setupConfigPath], cs) } where - join5 a b c d = join' a . join' b . join' c . join' d + curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h + + liftM7 fn ma mb mc md me mf mg = do + a <- ma; b <- mb; c <- mc; d <- md; e <- me; f <- mf; g <- mg + return (fn a b c d e f g) + + join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))] join' lb lc = [ (a, (b, c)) - | (a, b) <- lb - , (a', c) <- lc - , a == a' - ] - + | (a, b) <- lb + , (a', c) <- lc + , a == a' + ] withCabal :: (MonadIO m, GmEnv m) => m a -> m a withCabal action = do diff --git a/Language/Haskell/GhcMod/Modules.hs b/Language/Haskell/GhcMod/Modules.hs index d489138..03c69a8 100644 --- a/Language/Haskell/GhcMod/Modules.hs +++ b/Language/Haskell/GhcMod/Modules.hs @@ -14,7 +14,7 @@ import qualified GHC as G ---------------------------------------------------------------- -- | Listing installed modules. -modules :: (IOish m, GmEnv m) => m String +modules :: (IOish m, GmEnv m, GmLog m) => m String modules = do Options { detailed } <- options df <- runGmPkgGhc G.getSessionDynFlags diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 790a581..d6b830a 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -82,7 +82,7 @@ runLightGhc env action = do renv <- newIORef env flip runReaderT renv $ unLightGhc action -runGmPkgGhc :: (IOish m, GmEnv m) => LightGhc a -> m a +runGmPkgGhc :: (IOish m, GmEnv m, GmLog m) => LightGhc a -> m a runGmPkgGhc action = do pkgOpts <- packageGhcOptions withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action @@ -258,7 +258,7 @@ findCandidates scns = foldl1 Set.intersection scns pickComponent :: Set ChComponentName -> ChComponentName pickComponent scn = Set.findMin scn -packageGhcOptions :: (MonadIO m, GmEnv m) => m [GHCOption] +packageGhcOptions :: (MonadIO m, GmEnv m, GmLog m) => m [GHCOption] packageGhcOptions = do crdl <- cradle case cradleCabalFile crdl of diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 54a1c44..a90d01c 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -210,14 +210,15 @@ instance Monoid GmModuleGraph where data GmComponentType = GMCRaw | GMCResolved data GmComponent (t :: GmComponentType) eps = GmComponent { + gmcHomeModuleGraph :: GmModuleGraph, gmcName :: ChComponentName, gmcGhcOpts :: [GHCOption], + gmcGhcPkgOpts :: [GHCOption], gmcGhcSrcOpts :: [GHCOption], gmcGhcLangOpts :: [GHCOption], gmcRawEntrypoints :: ChEntrypoint, gmcEntrypoints :: eps, - gmcSourceDirs :: [FilePath], - gmcHomeModuleGraph :: GmModuleGraph + gmcSourceDirs :: [FilePath] } deriving (Eq, Ord, Show, Read, Generic, Functor) instance Serialize eps => Serialize (GmComponent t eps) From 3c76ba412f85d2541412e0622de4f7889366657f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 29 Apr 2015 18:44:46 +0200 Subject: [PATCH 086/207] Start rolling ghc-modi into the ghc-mod executable --- elisp/ghc-process.el | 8 +- src/GHCMod.hs | 175 ++++++++--------------------- src/GHCModi.hs | 262 ++----------------------------------------- src/Misc.hs | 68 ----------- 4 files changed, 58 insertions(+), 455 deletions(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 00aed43..7b09a26 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -20,7 +20,7 @@ (defvar-local ghc-process-callback nil) (defvar-local ghc-process-hook nil) -(defvar ghc-interactive-command "ghc-modi") +(defvar ghc-command "ghc-modi") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -35,7 +35,7 @@ (if hook1 (funcall hook1)) (let* ((cbuf (current-buffer)) (name ghc-process-process-name) - (buf (get-buffer-create (concat " ghc-modi:" name))) + (buf (get-buffer-create (concat " ghc-mod:" name))) (file (buffer-file-name)) (cpro (get-process name))) (ghc-with-current-buffer buf @@ -63,8 +63,8 @@ (t cpro))) (defun ghc-start-process (name buf) - (let* ((opts (append '("-b" "\n" "-l") (ghc-make-ghc-options))) - (pro (apply 'start-file-process name buf ghc-interactive-command opts))) + (let* ((opts (append '("--legacy-interactive" "-b" "\n" "-l") (ghc-make-ghc-options))) + (pro (apply 'start-file-process name buf ghc-command opts))) (set-process-filter pro 'ghc-process-filter) (set-process-sentinel pro 'ghc-process-sentinel) (set-process-query-on-exit-flag pro nil) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index df1985b..8d54aab 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -30,16 +30,10 @@ import Text.PrettyPrint import Misc - - progVersion :: String progVersion = - progName ++ " version " ++ showVersion version ++ " compiled by GHC " - ++ cProjectVersion ++ "\n" - --- TODO: remove (ghc) version prefix! -progName :: String -progName = unsafePerformIO $ takeFileName <$> getProgName + "ghc-mod version " ++ showVersion version ++ " compiled by GHC " + ++ cProjectVersion ++ "\n" optionUsage :: (String -> String) -> [OptDescr a] -> [String] optionUsage indent opts = concatMap optUsage opts @@ -64,15 +58,9 @@ optionUsage indent opts = concatMap optUsage opts ReqArg _ label -> s ++ label OptArg _ label -> s ++ "["++label++"]" +-- TODO: Generate the stuff below automatically usage :: String usage = - case progName of - "ghc-modi" -> ghcModiUsage - _ -> ghcModUsage - --- TODO: Generate the stuff below automatically -ghcModUsage :: String -ghcModUsage = "Usage: ghc-mod [OPTIONS...] COMMAND [CMD_ARGS...] \n\ \*Global Options (OPTIONS)*\n\ \ Global options can be specified before and after the command and\n\ @@ -200,32 +188,12 @@ ghcModUsage = \ Debugging information related to cabal component resolution.\n\ \\n\ \ - boot\n\ - \ Internal command used by the emacs frontend.\n" - -- "\n\ - -- \The following forms are supported so ghc-mod can be invoked by\n\ - -- \`cabal repl':\n\ - -- \\n\ - -- \ ghc-mod --make GHC_OPTIONS\n\ - -- \ Pass all options through to the GHC executable.\n\ - -- \\n\ - -- \ ghc-mod --interactive GHC_OPTIONS [--ghc-mod]\n\ - -- \ Start ghci emulation mode. GHC_OPTIONS are passed to the\n\ - -- \ GHC API. If `--ghc-mod' is given ghc-mod specific extensions\n\ - -- \ are enabled.\n" - where - indent = (" "++) - -ghcModiUsage :: String -ghcModiUsage = - "Usage: ghc-modi [OPTIONS...] COMMAND\n\ - \*Options*\n" - ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++ - "*Commands*\n\ - \ - version | --version\n\ - \ Print the version of the program.\n\ + \ Internal command used by the emacs frontend.\n\ \\n\ - \ - help | --help\n\ - \ Print this help message.\n" + \ - legacy-interactive [OPTIONS...]\n\ + \ ghc-modi compatibility mode.\n\ + \ *Options*\n" + ++ (unlines $ indent <$> optionUsage indent globalArgSpec) where indent = (" "++) @@ -255,6 +223,9 @@ cmdUsage cmd realUsage = unindent l = l in unlines $ unindent <$> c +ghcModStyle :: Style +ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 } + ---------------------------------------------------------------- option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a @@ -280,7 +251,7 @@ globalArgSpec = , option "b" ["boundary"] "Output line separator"$ reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s } - , option "g" ["ghcOpt"] "Option to be passed to GHC" $ + , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $ reqArg "OPT" $ \g o -> o { ghcUserOptions = g : ghcUserOptions o } @@ -297,10 +268,14 @@ globalArgSpec = parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String]) parseGlobalArgs argv - = case O.getOpt RequireOrder globalArgSpec argv of - (o,r,[] ) -> Right $ (foldr id defaultOptions o, r) - (_,_,errs) -> Left $ InvalidCommandLine $ Right $ - "Parsing command line options failed: " ++ concat errs + = case O.getOpt' Permute globalArgSpec argv of + (o,r,u,[]) -> Right $ (foldr id defaultOptions o, u ++ r) + (_,_,u,e) -> Left $ InvalidCommandLine $ Right $ + "Parsing command line options failed: " + ++ concat (e ++ map errUnrec u) + where + errUnrec :: String -> String + errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" parseCommandArgs :: [OptDescr (Options -> Options)] -> [String] @@ -322,8 +297,6 @@ data CmdError = UnknownCommand String instance Exception CmdError ----------------------------------------------------------------- - data InteractiveOptions = InteractiveOptions { ghcModExtensions :: Bool } @@ -338,9 +311,9 @@ handler = flip catches $ case e of Left cmd -> exitError $ "Usage for `"++cmd++"' command:\n\n" - ++ (cmdUsage cmd ghcModUsage) ++ "\n" - ++ progName ++ ": Invalid command line form." - Right msg -> exitError $ progName ++ ": " ++ msg + ++ (cmdUsage cmd usage) ++ "\n" + ++ "ghc-mod: Invalid command line form." + Right msg -> exitError $ "ghc-mod: " ++ msg ] main :: IO () @@ -362,78 +335,19 @@ main = handler $ do progMain :: (Options,[String]) -> IO () progMain (globalOptions,cmdArgs) = do - -- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args - -- _realGhcArgs = filter (/="--ghc-mod") ghcArgs - - -- (globalOptions,_cmdArgs) = parseGlobalArgs modArgs - - -- stripSeperator ("--":rest) = rest - -- stripSeperator l = l - - case progName of - "ghc-modi" -> do - legacyInteractive globalOptions =<< emptyNewUnGetLine - - - _ - -- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do - -- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith - - -- | "--interactive" `elem` ghcArgs -> do - -- let interactiveOptions = if "--ghc-mod" `elem` ghcArgs - -- then def { ghcModExtensions = True } - -- else def - - -- -- TODO: pass ghcArgs' to ghc API - -- putStrLn "\ninteractive\n" - -- --print realGhcArgs - -- (res, _) <- runGhcModT globalOptions $ undefined - -- case res of - -- Right s -> putStr s - -- Left e -> exitError $ render (gmeDoc e) - - - | otherwise -> do - (res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs - case res of - Right s -> putStr s - Left e -> exitError $ - renderStyle style { ribbonsPerLine = 1.2 } (gmeDoc e) - - -- Obtain ghc options by letting ourselfs be executed by - -- @cabal repl@ - -- TODO: need to do something about non-cabal projects - -- exe <- ghcModExecutable - -- let cabalArgs = ["repl", "-v0", "--with-ghc="++exe] - -- ++ (("--ghc-option="++) `map` ("--ghc-mod":"--":args)) - - -- print cabalArgs - - -- rawSystem "cabal" cabalArgs >>= exitWith - - - --- ghc-modi -legacyInteractive :: Options -> UnGetLine -> IO () -legacyInteractive opt ref = flip catches handlers $ do - (res,_) <- runGhcModT opt $ do - symdbreq <- liftIO $ newSymDbReq opt - world <- liftIO . getCurrentWorld =<< cradle - legacyInteractiveLoop symdbreq ref world - + (res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs case res of Right () -> return () - Left e -> putStrLn $ notGood $ render (gmeDoc e) - - where - handlers = [ Handler $ \Restart -> legacyInteractive opt ref ] - -isExitCodeException :: SomeException -> Bool -isExitCodeException e = isJust mExitCode - where - mExitCode :: Maybe ExitCode - mExitCode = fromException e + Left e -> exitError $ renderStyle ghcModStyle (gmeDoc e) +-- ghc-modi +legacyInteractive :: IOish m => GhcModT m () +legacyInteractive = + liftIO emptyNewUnGetLine >>= \ref -> do + opt <- options + symdbreq <- liftIO $ newSymDbReq opt + world <- liftIO . getCurrentWorld =<< cradle + legacyInteractiveLoop symdbreq ref world bug :: String -> IO () bug msg = do @@ -449,7 +363,6 @@ escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n" replace :: String -> String -> String -> String replace needle replacement = intercalate replacement . splitOn needle - legacyInteractiveLoop :: IOish m => SymDbReq -> UnGetLine -> World -> GhcModT m () legacyInteractiveLoop symdbreq ref world = do @@ -465,8 +378,6 @@ legacyInteractiveLoop symdbreq ref world = do liftIO $ ungetCommand ref cmdArg throw Restart - liftIO . prepareAutogen =<< cradle - let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg arg = concat args' cmd = dropWhileEnd isSpace cmd' @@ -497,7 +408,6 @@ legacyInteractiveLoop symdbreq ref world = do liftIO $ putStr res >> putStrLn "OK" >> hFlush stdout legacyInteractiveLoop symdbreq ref world - globalCommands :: [String] -> Maybe String globalCommands [] = Nothing globalCommands (cmd:_) = case cmd of @@ -505,11 +415,12 @@ globalCommands (cmd:_) = case cmd of _ | cmd == "version" || cmd == "--version" -> Just progVersion _ -> Nothing -ghcCommands :: IOish m => [String] -> GhcModT m String +ghcCommands :: IOish m => [String] -> GhcModT m () ghcCommands [] = fatalError "No command given (try --help)" -ghcCommands (cmd:args) = fn args +ghcCommands (cmd:args) = do + liftIO . putStr =<< action args where - fn = case cmd of + action = case cmd of _ | cmd == "list" || cmd == "modules" -> modulesCmd "lang" -> languagesCmd "flag" -> flagsCmd @@ -530,8 +441,11 @@ ghcCommands (cmd:args) = fn args "doc" -> pkgDocCmd "dumpsym" -> dumpSymbolCmd "boot" -> bootCmd + "legacy-interactive" -> legacyInteractiveCmd _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" + + newtype FatalError = FatalError String deriving (Show, Typeable) instance Exception FatalError @@ -543,7 +457,7 @@ exitError :: String -> IO a exitError msg = hPutStrLn stderr (dropWhileEnd (=='\n') msg) >> exitFailure fatalError :: String -> a -fatalError s = throw $ FatalError $ progName ++ ": " ++ s +fatalError s = throw $ FatalError $ "ghc-mod: " ++ s withParseCmd :: IOish m => [OptDescr (Options -> Options)] @@ -569,8 +483,9 @@ catchArgs cmd action = throw $ InvalidCommandLine (Left cmd) modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd, - debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd, - findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd + debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, + refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, + dumpSymbolCmd, bootCmd, legacyInteractiveCmd :: IOish m => [String] -> GhcModT m String modulesCmd = withParseCmd' "modules" s $ \[] -> modules @@ -604,6 +519,8 @@ infoCmd = withParseCmd [] $ action action [file,expr] = info file expr action _ = throw $ InvalidCommandLine (Left "info") +legacyInteractiveCmd = withParseCmd [] $ \[] -> legacyInteractive >> return "" + checkAction :: ([t] -> a) -> [t] -> a checkAction _ [] = throw $ InvalidCommandLine (Right "No files given.") checkAction action files = action files diff --git a/src/GHCModi.hs b/src/GHCModi.hs index c9e958c..0238957 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -1,262 +1,16 @@ {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} -- | WARNING --- This program in the process of being deprecated, use `ghc-mod --interactive` --- instead. - --- Commands: --- check --- find --- info --- type --- lint [hlint options] --- the format of hlint options is [String] because they may contain --- spaces and also may contain spaces. --- boot --- browse [:] --- quit --- --- Session separators: --- OK -- success --- NG -- failure +-- This program is deprecated, use `ghc-mod legacy-interactive` instead. module Main where -import Config (cProjectVersion) -import Control.Applicative ((<$>)) -import Control.Exception (SomeException(..)) -import qualified Control.Exception as E -import Control.Monad (when) -import CoreMonad (liftIO) -import Data.List (intercalate) -import Data.List.Split (splitOn) -import Data.Version (showVersion) -import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal -import Paths_ghc_mod -import System.Console.GetOpt -import System.Directory (setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (ExitCode, exitFailure) -import System.IO (hFlush,stdout) - -import Misc -import Utils - ----------------------------------------------------------------- - -progVersion :: String -progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n" - -argspec :: [OptDescr (Options -> Options)] -argspec = [ Option "b" ["boundary"] - (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep") - "specify line separator (default is Nul string)" - , Option "l" ["tolisp"] - (NoArg (\opts -> opts { outputStyle = LispStyle })) - "print as a list of Lisp" - , Option "g" [] - (ReqArg (\s opts -> opts { ghcUserOptions = s : ghcUserOptions opts }) "flag") "specify a ghc flag" - ] - -usage :: String -usage = progVersion - ++ "Usage:\n" - ++ "\t ghc-modi [-l] [-b sep] [-g flag]\n" - ++ "\t ghc-modi version\n" - ++ "\t ghc-modi help\n" - -parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) -parseArgs spec argv - = case getOpt Permute spec argv of - (o,n,[] ) -> (foldr id defaultOptions o, n) - (_,_,errs) -> E.throw (CmdArg errs) - ----------------------------------------------------------------- - --- Running two GHC monad threads disables the handling of --- C-c since installSignalHandlers is called twice, sigh. +import System.Exit +import System.Process +import System.Environment main :: IO () -main = E.handle cmdHandler $ - go =<< parseArgs argspec <$> getArgs - where - cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec - go (_,"help":_) = putStr $ usageInfo usage argspec - go (_,"version":_) = putStr progVersion - go (opt,_) = emptyNewUnGetLine >>= run opt - -run :: Options -> UnGetLine -> IO () -run opt ref = flip E.catches handlers $ do - cradle0 <- findCradle - let rootdir = cradleRootDir cradle0 --- c = cradle0 { cradleCurrentDir = rootdir } TODO: ????? - setCurrentDirectory rootdir - prepareAutogen cradle0 - -- Asynchronous db loading starts here. - symdbreq <- newSymDbReq opt - (res, _) <- runGhcModT opt $ do - crdl <- cradle - world <- liftIO $ getCurrentWorld crdl - loop symdbreq ref world - case res of - Right () -> return () - Left (GMECabalConfigure msg) -> do - putStrLn $ notGood $ "cabal configure failed: " ++ show msg - exitFailure - Left e -> bug $ show e - where - -- this is just in case. - -- If an error is caught here, it is a bug of GhcMod library. - handlers = [ E.Handler (\(_ :: ExitCode) -> return ()) - , E.Handler (\(_ :: Restart) -> run opt ref) - , E.Handler (\(SomeException e) -> bug $ show e) ] - -bug :: String -> IO () -bug msg = do - putStrLn $ notGood $ "BUG: " ++ msg - exitFailure - -notGood :: String -> String -notGood msg = "NG " ++ escapeNewlines msg - -escapeNewlines :: String -> String -escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n" - -replace :: String -> String -> String -> String -replace needle replacement = intercalate replacement . splitOn needle - ----------------------------------------------------------------- - -loop :: IOish m => SymDbReq -> UnGetLine -> World -> GhcModT m () -loop symdbreq ref world = do - -- blocking - cmdArg <- liftIO $ getCommand ref - -- after blocking, we need to see if the world has changed. - crdl <- cradle - changed <- liftIO $ didWorldChange world crdl - when changed $ do - liftIO $ ungetCommand ref cmdArg - E.throw Restart - cradle >>= liftIO . prepareAutogen - let (cmd,arg') = break (== ' ') cmdArg - arg = dropWhile (== ' ') arg' - (ret,ok) <- case cmd of - "check" -> checkStx arg - "find" -> findSym arg symdbreq - "lint" -> lintStx arg - "info" -> showInfo arg - "type" -> showType arg - "split" -> doSplit arg - "sig" -> doSig arg - "refine" -> doRefine arg - "auto" -> doAuto arg - "boot" -> bootIt - "browse" -> browseIt arg - "quit" -> return ("quit", False) - "" -> return ("quit", False) - _ -> return ([], True) - if ok then do - liftIO $ putStr ret - liftIO $ putStrLn "OK" - else do - liftIO $ putStrLn $ notGood ret - liftIO $ hFlush stdout - when ok $ loop symdbreq ref world - ----------------------------------------------------------------- - -checkStx :: IOish m => FilePath -> GhcModT m (String, Bool) -checkStx file = do - eret <- check [file] - case eret of - Right ret -> return (ret, True) - Left ret -> return (ret, True) - ----------------------------------------------------------------- - -findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool) -findSym sym symdbreq = do - db <- getDb symdbreq >>= checkDb symdbreq - ret <- lookupSymbol sym db - return (ret, True) - -lintStx :: IOish m => FilePath -> GhcModT m (String, Bool) -lintStx optFile = do - ret <- withOptions changeOpt $ lint file - return (ret, True) - where - (opts,file) = parseLintOptions optFile - hopts = if opts == "" then [] else read opts - changeOpt o = o { hlintOpts = hopts } - --- | --- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name" --- (["--ignore=Use camelCase", "--ignore=Eta reduce"], "file name") --- >>> parseLintOptions "file name" --- ([], "file name") -parseLintOptions :: String -> (String, String) -parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of - ("","") -> ([], optFile) - (opt',file') -> (opt', dropWhile (== ' ') file') - where - brk _ [] = ([],[]) - brk p (x:xs') - | p x = ([x],xs') - | otherwise = let (ys,zs) = brk p xs' in (x:ys,zs) - ----------------------------------------------------------------- - -showInfo :: IOish m => FilePath -> GhcModT m (String, Bool) -showInfo fileArg = do - let [file, expr] = splitN 2 fileArg - ret <- info file expr - return (ret, True) - -showType :: IOish m => FilePath -> GhcModT m (String, Bool) -showType fileArg = do - let [file, line, column] = splitN 3 fileArg - ret <- types file (read line) (read column) - return (ret, True) - -doSplit :: IOish m => FilePath -> GhcModT m (String, Bool) -doSplit fileArg = do - let [file, line, column] = splitN 3 fileArg - ret <- splits file (read line) (read column) - return (ret, True) - -doSig :: IOish m => FilePath -> GhcModT m (String, Bool) -doSig fileArg = do - let [file, line, column] = splitN 3 fileArg - ret <- sig file (read line) (read column) - return (ret, True) - -doRefine :: IOish m => FilePath -> GhcModT m (String, Bool) -doRefine fileArg = do - let [file, line, column, expr] = splitN 4 fileArg - ret <- refine file (read line) (read column) expr - return (ret, True) - -doAuto :: IOish m => FilePath -> GhcModT m (String, Bool) -doAuto fileArg = do - let [file, line, column] = splitN 3 fileArg - ret <- auto file (read line) (read column) - return (ret, True) - ----------------------------------------------------------------- - -bootIt :: IOish m => GhcModT m (String, Bool) -bootIt = do - ret <- boot - return (ret, True) - -browseIt :: IOish m => ModuleString -> GhcModT m (String, Bool) -browseIt mdl = do - let (det,rest') = break (== ' ') mdl - rest = dropWhile (== ' ') rest' - ret <- if det == "-d" - then withOptions setDetailed (browse rest) - else browse mdl - return (ret, True) - where - setDetailed opt = opt { detailed = True } +main = do + args <- getArgs + h <- spawnProcess "ghc-mod" $ ["legacy-interactive"] ++ args + exitWith =<< waitForProcess h diff --git a/src/Misc.hs b/src/Misc.hs index 21248ad..f7f622e 100644 --- a/src/Misc.hs +++ b/src/Misc.hs @@ -11,22 +11,14 @@ module Misc ( , newSymDbReq , getDb , checkDb - , prepareAutogen ) where import Control.Applicative ((<$>)) -import Control.Concurrent (threadDelay) import Control.Concurrent.Async (Async, async, wait) import Control.Exception (Exception) -import Control.Monad (unless, when) import CoreMonad (liftIO) import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.List (isPrefixOf) -import Data.Maybe (isJust) import Data.Typeable (Typeable) -import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.IO (openBinaryFile, IOMode(..)) -import System.Process import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal @@ -92,63 +84,3 @@ checkDb (SymDbReq ref act) db = do hoistGhcModT =<< liftIO (wait req) else return db - ----------------------------------------------------------------- - -build :: IO ProcessHandle -build = do -#ifdef WINDOWS - nul <- openBinaryFile "NUL" AppendMode -#else - nul <- openBinaryFile "/dev/null" AppendMode -#endif - (_, _, _, hdl) <- createProcess $ pro nul - return hdl - where - pro nul = CreateProcess { - cmdspec = RawCommand "cabal" ["build"] - , cwd = Nothing - , env = Nothing - , std_in = Inherit - , std_out = UseHandle nul - , std_err = UseHandle nul - , close_fds = False -#if __GLASGOW_HASKELL__ >= 702 - , create_group = True -#endif -#if __GLASGOW_HASKELL__ >= 707 - , delegate_ctlc = False -#endif - } - -autogen :: String -autogen = "dist/build/autogen" - -isAutogenPrepared :: IO Bool -isAutogenPrepared = do - exist <- doesDirectoryExist autogen - if exist then do - files <- filter ("." `isPrefixOf`) <$> getDirectoryContents autogen - if length files >= 2 then - return True - else - return False - else - return False - -watch :: Int -> ProcessHandle -> IO () -watch 0 _ = return () -watch n hdl = do - prepared <- isAutogenPrepared - if prepared then - interruptProcessGroupOf hdl - else do - threadDelay 100000 - watch (n - 1) hdl - -prepareAutogen :: Cradle -> IO () -prepareAutogen crdl = when (isJust $ cradleCabalFile crdl) $ do - prepared <- isAutogenPrepared - unless prepared $ do - hdl <- build - watch 30 hdl From de3d3a5f197c7e87c4c8ab5aef2fd9a6051bafb3 Mon Sep 17 00:00:00 2001 From: Anthony Cowley Date: Fri, 24 Apr 2015 18:58:23 -0400 Subject: [PATCH 087/207] Fix #464. Expand path relative to the project root directory. --- elisp/ghc-check.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el index eafadfa..3d551a9 100644 --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -132,7 +132,7 @@ nil does not display errors/warnings. info infos) (dolist (err errs (nreverse infos)) (when (string-match regex err) - (let* ((file (expand-file-name (match-string 1 err))) ;; for Windows + (let* ((file (expand-file-name (match-string 1 err) (ghc-get-project-root))) ;; for Windows (line (string-to-number (match-string 2 err))) (coln (string-to-number (match-string 3 err))) (msg (match-string 4 err)) From 45c5a0611710e26b882f896ff27a4c5d0d7c536b Mon Sep 17 00:00:00 2001 From: Kevin Boulain Date: Sat, 18 Apr 2015 23:00:15 +0200 Subject: [PATCH 088/207] turn-off-haskell-font-lock and turn-on-haskell-font-lock functions have been removed from haskell-mode --- elisp/ghc-func.el | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el index 97f749b..83d1840 100644 --- a/elisp/ghc-func.el +++ b/elisp/ghc-func.el @@ -182,9 +182,19 @@ (funcall ins-func) (goto-char (point-min)) (if (not fontify) - (turn-off-haskell-font-lock) + ;; turn-off-haskell-font-lock has been removed from haskell-mode + ;; test if the function is defined in our version + (if (fboundp 'turn-off-haskell-font-lock) + (turn-off-haskell-font-lock) + ;; it's not defined, fallback on font-lock-mode + (font-lock-mode -1)) (haskell-font-lock-defaults-create) - (turn-on-haskell-font-lock))) + ;; turn-on-haskell-font-lock has been removed from haskell-mode + ;; test if the function is defined in our version + (if (fboundp 'turn-on-haskell-font-lock) + (turn-on-haskell-font-lock) + ;; it's not defined, fallback on font-lock-mode + (turn-on-font-lock)))) (display-buffer buf '((display-buffer-reuse-window display-buffer-pop-up-window)))))) From d11b12676ed1ca212e2d67ce73b5ce99c18ce0d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 5 May 2015 16:09:54 +0200 Subject: [PATCH 089/207] Fix pretty printing of logging output --- Language/Haskell/GhcMod/HomeModuleGraph.hs | 2 +- Language/Haskell/GhcMod/Logging.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index 12badf2..7aafc16 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -222,7 +222,7 @@ updateHomeModuleGraph' env smp0 = do Left errs -> do -- TODO: Remember these and present them as proper errors if this is -- the file the user is looking at. - gmLog GmWarning ("preprocess' " ++ show fn) $ vcat $ map strDoc errs + gmLog GmWarning ("preprocess " ++ show fn) $ empty $+$ (vcat $ map text errs) return Nothing imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath) diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 37684a5..142bd40 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -60,8 +60,8 @@ gmLog level loc' doc = do GhcModLog { gmLogLevel = level' } <- gmlHistory let loc | loc' == "" = empty - | otherwise = empty <+>: text loc' - msg = gmRenderDoc $ (gmLogLevelDoc level <> loc) <+>: doc + | otherwise = text loc' <+>: empty + msg = gmRenderDoc $ gmLogLevelDoc level <+>: sep [loc, doc] msg' = dropWhileEnd isSpace msg when (Just level <= level') $ From 0f1e653f7f89858eef2b2fc8ce7f9bd094332f6f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 6 May 2015 16:13:08 +0200 Subject: [PATCH 090/207] Change some logging stuff --- Language/Haskell/GhcMod/Info.hs | 4 +++- Language/Haskell/GhcMod/Logging.hs | 12 ++++++------ Language/Haskell/GhcMod/Monad/Types.hs | 5 +++-- test/TestUtils.hs | 2 +- 4 files changed, 13 insertions(+), 10 deletions(-) diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 0fa74e2..d109f02 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -64,7 +64,9 @@ types file lineNo colNo = convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes where - handler (SomeException _) = return [] + handler (SomeException ex) = do + gmLog GmException "types" $ showDoc ex + return [] getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] getSrcSpanType modSum lineNo colNo = do diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 142bd40..019c12b 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -57,16 +57,16 @@ decreaseLogLevel l = pred l -- False gmLog :: (MonadIO m, GmLog m) => GmLogLevel -> String -> Doc -> m () gmLog level loc' doc = do - GhcModLog { gmLogLevel = level' } <- gmlHistory + GhcModLog { gmLogLevel = Just level' } <- gmlHistory let loc | loc' == "" = empty | otherwise = text loc' <+>: empty - msg = gmRenderDoc $ gmLogLevelDoc level <+>: sep [loc, doc] - msg' = dropWhileEnd isSpace msg + msgDoc = gmLogLevelDoc level <+>: sep [loc, doc] + msg = dropWhileEnd isSpace $ gmRenderDoc msgDoc - when (Just level <= level') $ - liftIO $ hPutStrLn stderr msg' - gmlJournal (GhcModLog Nothing [(level, render loc, msg)]) + when (level <= level') $ liftIO $ hPutStrLn stderr msg + + gmlJournal (GhcModLog Nothing [(level, loc', msgDoc)]) newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a } deriving (Functor, Applicative, Monad) diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index ab644db..f769a5b 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -101,6 +101,7 @@ import Data.Maybe import Data.Monoid import Data.IORef import Distribution.Helper +import Text.PrettyPrint (Doc) import qualified MonadUtils as GHC (MonadIO(..)) @@ -111,8 +112,8 @@ data GhcModEnv = GhcModEnv { data GhcModLog = GhcModLog { gmLogLevel :: Maybe GmLogLevel, - gmLogMessages :: [(GmLogLevel, String, String)] - } deriving (Eq, Show, Read) + gmLogMessages :: [(GmLogLevel, String, Doc)] + } deriving (Show) instance Monoid GhcModLog where mempty = GhcModLog (Just GmPanic) mempty diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 1f52a1d..877e229 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -78,7 +78,7 @@ runE = runErrorT runNullLog :: MonadIO m => JournalT GhcModLog m a -> m a runNullLog action = do (a,w) <- runJournalT action - when (w /= mempty) $ liftIO $ print w + liftIO $ print w return a shouldReturnError :: Show a From d9bc2092ab7bccb17ac5cb54343fefb95cfc5e88 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 6 May 2015 16:14:37 +0200 Subject: [PATCH 091/207] Remove dead code --- ghc-mod.cabal | 1 - src/Utils.hs | 27 --------------------------- 2 files changed, 28 deletions(-) delete mode 100644 src/Utils.hs diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 5879f66..bc5a01c 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -175,7 +175,6 @@ Executable ghc-modi Main-Is: GHCModi.hs Other-Modules: Paths_ghc_mod Misc - Utils GHC-Options: -Wall -threaded -fno-warn-deprecations if os(windows) Cpp-Options: -DWINDOWS diff --git a/src/Utils.hs b/src/Utils.hs deleted file mode 100644 index c91151d..0000000 --- a/src/Utils.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Utils where - --- | --- --- >>> split "foo bar baz" --- ["foo","bar baz"] --- >>> split "foo bar baz" --- ["foo","bar baz"] -split :: String -> [String] -split xs = [ys, dropWhile isSpace zs] - where - isSpace = (== ' ') - (ys,zs) = break isSpace xs - --- | --- --- >>> splitN 0 "foo bar baz" --- ["foo","bar baz"] --- >>> splitN 2 "foo bar baz" --- ["foo","bar baz"] --- >>> splitN 3 "foo bar baz" --- ["foo","bar","baz"] -splitN :: Int -> String -> [String] -splitN n xs - | n <= 2 = split xs - | otherwise = let [ys,zs] = split xs - in ys : splitN (n - 1) zs From c1bdb2d52c5ac3bfdd9ba998333c9e1dd8cca30b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 6 May 2015 16:15:04 +0200 Subject: [PATCH 092/207] Fix ghc-modi compat exe --- src/GHCMod.hs | 6 ++---- src/GHCModi.hs | 5 ++++- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 8d54aab..d83aae9 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -190,10 +190,8 @@ usage = \ - boot\n\ \ Internal command used by the emacs frontend.\n\ \\n\ - \ - legacy-interactive [OPTIONS...]\n\ - \ ghc-modi compatibility mode.\n\ - \ *Options*\n" - ++ (unlines $ indent <$> optionUsage indent globalArgSpec) + \ - legacy-interactive\n\ + \ ghc-modi compatibility mode.\n" where indent = (" "++) diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 0238957..602e3e1 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -7,10 +7,13 @@ module Main where import System.Exit import System.Process +import System.FilePath import System.Environment +import Paths_ghc_mod main :: IO () main = do args <- getArgs - h <- spawnProcess "ghc-mod" $ ["legacy-interactive"] ++ args + bindir <- getBinDir + h <- spawnProcess (bindir "ghc-mod") $ ["legacy-interactive"] ++ args exitWith =<< waitForProcess h From 644ee82a02c017964f061727485964c40b0b236f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 6 May 2015 16:16:13 +0200 Subject: [PATCH 093/207] elisp: fix non expanded path comparison --- elisp/ghc-check.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el index 3d551a9..3f6a032 100644 --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -167,13 +167,13 @@ nil does not display errors/warnings. ;; If this is a bottleneck for a large code, let's fix. (goto-char (point-min)) (cond - ((and (string= ofile file) hole) + ((and (string= (file-truename ofile) (file-truename file)) hole) (forward-line (1- line)) (forward-char (1- coln)) (setq beg (point)) (forward-char (length hole)) (setq end (point))) - ((string= ofile file) + ((string= (string= (file-truename ofile) (file-truename file))) (forward-line (1- line)) (while (eq (char-after) 32) (forward-char)) (setq beg (point)) From aa75d2213e9ae8e93511ad1d2cc4a575805776f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 6 May 2015 16:16:47 +0200 Subject: [PATCH 094/207] ghc-mod's type result is not a guess! --- elisp/ghc-info.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el index eed8bd5..d7854c5 100644 --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -82,7 +82,7 @@ (if (null tinfos) (progn (ghc-type-clear-overlay) - (message "Cannot guess type")) + (message "Cannot determine type")) (let* ((tinfo (nth (ghc-type-get-ix) tinfos)) (type (ghc-tinfo-get-info tinfo)) (beg-line (ghc-tinfo-get-beg-line tinfo)) From e202fabc392b6d4b1b7e47424f1b79fa4ad7c4da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 6 May 2015 16:32:53 +0200 Subject: [PATCH 095/207] elisp: Fix usage of legacy-interactive --- Language/Haskell/GhcMod/Pretty.hs | 1 + Language/Haskell/GhcMod/Types.hs | 3 ++- elisp/ghc-process.el | 4 ++-- src/GHCMod.hs | 28 ++++++++++++++++------------ 4 files changed, 21 insertions(+), 15 deletions(-) diff --git a/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs index 57e39a8..d14512a 100644 --- a/Language/Haskell/GhcMod/Pretty.hs +++ b/Language/Haskell/GhcMod/Pretty.hs @@ -38,6 +38,7 @@ gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n gmLogLevelDoc :: GmLogLevel -> Doc +gmLogLevelDoc GmSilent = error "GmSilent MUST not be used for log messages" gmLogLevelDoc GmPanic = text "PANIC" gmLogLevelDoc GmException = text "EXCEPTION" gmLogLevelDoc GmError = text "ERROR" diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index a90d01c..b1be7f0 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -163,7 +163,8 @@ type ModuleString = String -- | A Module type Module = [String] -data GmLogLevel = GmPanic +data GmLogLevel = GmSilent + | GmPanic | GmException | GmError | GmWarning diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 7b09a26..b44416e 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -20,7 +20,7 @@ (defvar-local ghc-process-callback nil) (defvar-local ghc-process-hook nil) -(defvar ghc-command "ghc-modi") +(defvar ghc-command "ghc-mod") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -63,7 +63,7 @@ (t cpro))) (defun ghc-start-process (name buf) - (let* ((opts (append '("--legacy-interactive" "-b" "\n" "-l") (ghc-make-ghc-options))) + (let* ((opts (append '("legacy-interactive" "-b" "\n" "-l" "-s") (ghc-make-ghc-options))) (pro (apply 'start-file-process name buf ghc-command opts))) (set-process-filter pro 'ghc-process-filter) (set-process-sentinel pro 'ghc-process-sentinel) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index d83aae9..eff407f 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -11,7 +11,6 @@ import Data.Version (showVersion) import Data.Default import Data.List import Data.List.Split -import Data.Maybe import Data.Char (isSpace) import Exception import Language.Haskell.GhcMod @@ -20,12 +19,10 @@ import Paths_ghc_mod import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import qualified System.Console.GetOpt as O import System.Directory (setCurrentDirectory) -import System.Environment (getArgs,getProgName) +import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush) -import System.IO.Unsafe (unsafePerformIO) -import System.FilePath (takeFileName) -import System.Exit (ExitCode, exitSuccess) +import System.Exit (exitSuccess) import Text.PrettyPrint import Misc @@ -232,16 +229,23 @@ option s l udsc dsc = Option s l dsc udsc reqArg :: String -> (String -> a) -> ArgDescr a reqArg udsc dsc = ReqArg dsc udsc +optArg :: String -> (Maybe String -> a) -> ArgDescr a +optArg udsc dsc = OptArg dsc udsc + +intToLogLevel :: Int -> GmLogLevel +intToLogLevel = toEnum + globalArgSpec :: [OptDescr (Options -> Options)] globalArgSpec = - [ option "v" ["verbose"] "Can be given multiple times to be increasingly\ - \ be more verbose." $ - NoArg $ \o -> o { logLevel = increaseLogLevel (logLevel o) } - - , option "s" [] "Can be given multiple times to be increasingly be less\ - \ verbose." $ - NoArg $ \o -> o { logLevel = decreaseLogLevel (logLevel o) } + [ option "v" ["verbose"] "Increase or set log level. (0-6)" $ + optArg "LEVEL" $ \ml o -> o { + logLevel = case ml of + Nothing -> increaseLogLevel (logLevel o) + Just l -> toEnum $ min 6 $ read l + } + , option "s" [] "Be silent, set log level to 0" $ + NoArg $ \o -> o { logLevel = toEnum 0 } , option "l" ["tolisp"] "Format output as an S-Expression" $ NoArg $ \o -> o { outputStyle = LispStyle } From e6fc3dd8d2346a553026f4913678b4f9831080c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 8 May 2015 00:06:08 +0200 Subject: [PATCH 096/207] Fix tests --- Language/Haskell/GhcMod/Target.hs | 3 ++- test/TestUtils.hs | 1 - 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index d6b830a..76fbc76 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -114,7 +114,8 @@ dropSession = do -- TODO: This is still not enough, there seem to still be references to -- GHC's state around afterwards. liftIO $ writeIORef ref (error "HscEnv: session was dropped") - liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped") + -- Not available on ghc<7.8; didn't really help anyways + -- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped") Nothing -> return () diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 877e229..dfe0644 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -19,7 +19,6 @@ import Language.Haskell.GhcMod.Types import Control.Arrow import Control.Applicative -import Control.Monad (when) import Control.Monad.Error (ErrorT, runErrorT) import Control.Monad.Trans.Journal import Data.List.Split From 133ec67350af5e8fa1d526a54d713d0022042401 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 13 May 2015 11:02:24 +0200 Subject: [PATCH 097/207] Fix command line parsing --- src/GHCMod.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index eff407f..49e4099 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -270,7 +270,7 @@ globalArgSpec = parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String]) parseGlobalArgs argv - = case O.getOpt' Permute globalArgSpec argv of + = case O.getOpt' RequireOrder globalArgSpec argv of (o,r,u,[]) -> Right $ (foldr id defaultOptions o, u ++ r) (_,_,u,e) -> Left $ InvalidCommandLine $ Right $ "Parsing command line options failed: " From 05b9445f6e88341b74255edb12af7ef5f3ebfe78 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Fri, 15 May 2015 13:42:27 +0300 Subject: [PATCH 098/207] fix and improve ghc-check-highlight-original-buffer --- elisp/ghc-check.el | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el index 3f6a032..20de8b7 100644 --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -167,18 +167,20 @@ nil does not display errors/warnings. ;; If this is a bottleneck for a large code, let's fix. (goto-char (point-min)) (cond - ((and (string= (file-truename ofile) (file-truename file)) hole) - (forward-line (1- line)) - (forward-char (1- coln)) - (setq beg (point)) - (forward-char (length hole)) - (setq end (point))) - ((string= (string= (file-truename ofile) (file-truename file))) - (forward-line (1- line)) - (while (eq (char-after) 32) (forward-char)) - (setq beg (point)) - (forward-line) - (setq end (1- (point)))) + ((string= (file-truename ofile) (file-truename file)) + (if hole + (progn + (forward-line (1- line)) + (forward-char (1- coln)) + (setq beg (point)) + (forward-char (length hole)) + (setq end (point))) + (progn + (forward-line (1- line)) + (skip-chars-forward " ") + (setq beg (point)) + (forward-line) + (setq end (1- (point)))))) (t (setq beg (point)) (forward-line) From b05509812754a409f3e3de2ae13a882507004cab Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Sun, 12 Apr 2015 21:24:26 +0300 Subject: [PATCH 099/207] use standard findFile instead of hand-rolled one --- Language/Haskell/GhcMod/Target.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 76fbc76..d535635 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -37,10 +37,8 @@ import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils import Data.Maybe -import Data.Monoid import Data.Either import Data.Foldable (foldrM) import Data.Traversable (traverse) @@ -315,7 +313,7 @@ resolveModule :: MonadIO m => resolveModule env _srcDirs (Right mn) = liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn resolveModule env srcDirs (Left fn') = liftIO $ do - mfn <- findFile' srcDirs fn' + mfn <- findFile srcDirs fn' case mfn of Nothing -> return Nothing Just fn'' -> do @@ -327,9 +325,6 @@ resolveModule env srcDirs (Left fn') = liftIO $ do case mmn of Nothing -> mkMainModulePath fn Just mn -> ModulePath mn fn - where - findFile' dirs file = - getFirst . mconcat <$> mapM (fmap First . mightExist . (file)) dirs resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [Either FilePath ModuleName] @@ -365,7 +360,6 @@ resolveGmComponents mumns cs = do else insertUpdated m c gmsPut s { gmComponents = m' } return m' - where foldrM' b fa f = foldrM f b fa insertUpdated m c = do From f7717ee1ee55a66744c4b9a86107a48e1013eb54 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Sun, 17 May 2015 23:17:56 +0300 Subject: [PATCH 100/207] fix typo --- Language/Haskell/GhcMod/Target.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index d535635..68bab4e 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -181,7 +181,7 @@ targetGhcOptions crdl sefnmn = do if noCandidates && noModuleHasAnyAssignment then do - gmLog GmWarning "" $ strDoc $ "Could not find a componenet assignment, falling back to sandbox only project options." + gmLog GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to sandbox only project options." sandboxOpts crdl else do when noCandidates $ From 3598dda20ac075f4403e49010bb7d4f0c0fea973 Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Tue, 19 May 2015 14:00:20 +0200 Subject: [PATCH 101/207] Fixed typo --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 74aa472..3eb99f4 100644 --- a/README.md +++ b/README.md @@ -46,7 +46,7 @@ all sorts of nasty conflicts. ## Custom ghc-mod cradle -To customize the package databases used by `ghc-mod`, put a file called `.ghc-mod.cradle` beside the `.cabal` file with the following syntax: +To customize the package databases used by `ghc-mod`, put a file called `ghc-mod.cradle` beside the `.cabal` file with the following syntax: ``` temp directory root From 0bb1671238cfdf02f9adc7b24700bd9e630c908a Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Tue, 19 May 2015 14:04:15 +0200 Subject: [PATCH 102/207] Code cleanup --- Language/Haskell/GhcMod/PathsAndFiles.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 00ad384..0dcc6f8 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -35,6 +35,7 @@ import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Caching import qualified Language.Haskell.GhcMod.Utils as U +import Utils (mightExist) -- | Guaranteed to be a path to a directory with no trailing slash. type DirPath = FilePath @@ -211,7 +212,4 @@ cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-helper" findCradleFile :: FilePath -> IO (Maybe FilePath) findCradleFile directory = do let path = directory "ghc-mod.cradle" - exists <- doesFileExist $ path - case exists of - True -> return $ Just path - False -> return Nothing + mightExist path From 76e5af817af41a4903957fc3a768f0eb2f19ad55 Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Tue, 19 May 2015 15:25:22 +0200 Subject: [PATCH 103/207] Not passing package db flags in default case --- Language/Haskell/GhcMod/CabalHelper.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 1ea7a55..42bb744 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -101,7 +101,10 @@ withCabal action = do opts <- options liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $ withDirectory_ (cradleRootDir crdl) $ do - let pkgDbArgs = "--package-db=clear" : map pkgDbArg (cradlePkgDbStack crdl) + let pkgDbStack = cradlePkgDbStack crdl + pkgDbArgs = if pkgDbStack == defaultPkgDbStack + then [] + else "--package-db=clear" : map pkgDbArg pkgDbStack progOpts = [ "--with-ghc=" ++ T.ghcProgram opts ] -- Only pass ghc-pkg if it was actually set otherwise we @@ -118,3 +121,6 @@ pkgDbArg :: GhcPkgDb -> String pkgDbArg GlobalDb = "--package-db=global" pkgDbArg UserDb = "--package-db=user" pkgDbArg (PackageDb p) = "--package-db=" ++ p + +defaultPkgDbStack :: [GhcPkgDb] +defaultPkgDbStack = [GlobalDb, UserDb] From 5f41e8828a699b1b7ebe4e7d84826a86eac3bc5b Mon Sep 17 00:00:00 2001 From: Daniel Vigovszky Date: Tue, 19 May 2015 19:50:36 +0200 Subject: [PATCH 104/207] Revert "Not passing package db flags in default case" This reverts commit 76e5af817af41a4903957fc3a768f0eb2f19ad55. --- Language/Haskell/GhcMod/CabalHelper.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 42bb744..1ea7a55 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -101,10 +101,7 @@ withCabal action = do opts <- options liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $ withDirectory_ (cradleRootDir crdl) $ do - let pkgDbStack = cradlePkgDbStack crdl - pkgDbArgs = if pkgDbStack == defaultPkgDbStack - then [] - else "--package-db=clear" : map pkgDbArg pkgDbStack + let pkgDbArgs = "--package-db=clear" : map pkgDbArg (cradlePkgDbStack crdl) progOpts = [ "--with-ghc=" ++ T.ghcProgram opts ] -- Only pass ghc-pkg if it was actually set otherwise we @@ -121,6 +118,3 @@ pkgDbArg :: GhcPkgDb -> String pkgDbArg GlobalDb = "--package-db=global" pkgDbArg UserDb = "--package-db=user" pkgDbArg (PackageDb p) = "--package-db=" ++ p - -defaultPkgDbStack :: [GhcPkgDb] -defaultPkgDbStack = [GlobalDb, UserDb] From ac31e6edc27e252c984ab4be1df205b09866876f Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Sun, 17 May 2015 23:22:05 +0300 Subject: [PATCH 105/207] don't silently ignore case when ghc process is already running in ghc-with-process --- elisp/ghc-process.el | 45 +++++++++++++++++++++++--------------------- 1 file changed, 24 insertions(+), 21 deletions(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index b44416e..0519549 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -18,7 +18,8 @@ (defvar-local ghc-process-original-buffer nil) (defvar-local ghc-process-original-file nil) (defvar-local ghc-process-callback nil) -(defvar-local ghc-process-hook nil) +(defvar-local ghc-process-hook nil + "Hook that will be called upon successfull completion of ghc-mod command.") (defvar ghc-command "ghc-mod") @@ -30,26 +31,28 @@ (defun ghc-with-process (cmd callback &optional hook1 hook2) (unless ghc-process-process-name (setq ghc-process-process-name (ghc-get-project-root))) - (when (and ghc-process-process-name (not ghc-process-running)) - (setq ghc-process-running t) - (if hook1 (funcall hook1)) - (let* ((cbuf (current-buffer)) - (name ghc-process-process-name) - (buf (get-buffer-create (concat " ghc-mod:" name))) - (file (buffer-file-name)) - (cpro (get-process name))) - (ghc-with-current-buffer buf - (setq ghc-process-original-buffer cbuf) - (setq ghc-process-original-file file) - (setq ghc-process-callback callback) - (setq ghc-process-hook hook2) - (erase-buffer) - (let ((pro (ghc-get-process cpro name buf))) - (process-send-string pro cmd) - (when ghc-debug - (ghc-with-debug-buffer - (insert (format "%% %s" cmd)))) - pro))))) + (if ghc-process-running + (error "ghc process already running") + (progn + (when ghc-process-running t) + (if hook1 (funcall hook1)) + (let* ((cbuf (current-buffer)) + (name ghc-process-process-name) + (buf (get-buffer-create (concat " ghc-mod:" name))) + (file (buffer-file-name)) + (cpro (get-process name))) + (ghc-with-current-buffer buf + (setq ghc-process-original-buffer cbuf) + (setq ghc-process-original-file file) + (setq ghc-process-callback callback) + (setq ghc-process-hook hook2) + (erase-buffer) + (let ((pro (ghc-get-process cpro name buf))) + (process-send-string pro cmd) + (when ghc-debug + (ghc-with-debug-buffer + (insert (format "%% %s" cmd)))) + pro)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 84134e1feecf4ec7d4de48067d278a950eda01e6 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Sun, 17 May 2015 23:22:56 +0300 Subject: [PATCH 106/207] replace redundant liftM7 function with applicatives --- Language/Haskell/GhcMod/CabalHelper.hs | 32 +++++++++++--------------- Language/Haskell/GhcMod/Target.hs | 6 ++--- 2 files changed, 17 insertions(+), 21 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 7c6de37..d5a1f3f 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -38,7 +38,7 @@ import Paths_ghc_mod as GhcMod -- | Only package related GHC options, sufficient for things that don't need to -- access home modules -getGhcPkgOptions :: (MonadIO m, GmEnv m, GmLog m) +getGhcPkgOptions :: (Applicative m, MonadIO m, GmEnv m, GmLog m) => m [(ChComponentName, [GHCOption])] getGhcPkgOptions = map (\c -> (gmcName c, gmcGhcPkgOpts c)) `liftM` getComponents @@ -54,7 +54,7 @@ helperProgs opts = Programs { -- -- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by -- 'resolveGmComponents'. -getComponents :: (MonadIO m, GmEnv m, GmLog m) +getComponents :: (Applicative m, MonadIO m, GmEnv m, GmLog m) => m [GmComponent GMCRaw ChEntrypoint] getComponents = do opt <- options @@ -67,35 +67,31 @@ getComponents = do ) withCabal $ cached cradleRootDir cabalHelperCache d -cabalHelperCache :: MonadIO m => Cached m - (Programs, FilePath, (Version, String)) - [GmComponent GMCRaw ChEntrypoint] +cabalHelperCache + :: (Functor m, Applicative m, MonadIO m) + => Cached m (Programs, FilePath, (Version, String)) [GmComponent GMCRaw ChEntrypoint] cabalHelperCache = Cached { cacheFile = cabalHelperCacheFile, cachedAction = \ _ (progs, root, _) _ -> runQuery' progs root $ do - q <- liftM7 join7 - ghcOptions - ghcPkgOptions - ghcSrcOptions - ghcLangOptions - entrypoints - entrypoints - sourceDirs + q <- join7 + <$> ghcOptions + <*> ghcPkgOptions + <*> ghcSrcOptions + <*> ghcLangOptions + <*> entrypoints + <*> entrypoints + <*> sourceDirs let cs = flip map q $ curry8 (GmComponent mempty) return ([setupConfigPath], cs) } where curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h - liftM7 fn ma mb mc md me mf mg = do - a <- ma; b <- mb; c <- mc; d <- md; e <- me; f <- mf; g <- mg - return (fn a b c d e f g) - join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))] join' lb lc = [ (a, (b, c)) - | (a, b) <- lb + | (a, b) <- lb , (a', c) <- lc , a == a' ] diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 68bab4e..7bcbb64 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -18,7 +18,7 @@ module Language.Haskell.GhcMod.Target where import Control.Arrow -import Control.Applicative ((<$>)) +import Control.Applicative (Applicative, (<$>)) import Control.Monad.Reader (runReaderT) import GHC import GHC.Paths (libdir) @@ -257,11 +257,11 @@ findCandidates scns = foldl1 Set.intersection scns pickComponent :: Set ChComponentName -> ChComponentName pickComponent scn = Set.findMin scn -packageGhcOptions :: (MonadIO m, GmEnv m, GmLog m) => m [GHCOption] +packageGhcOptions :: (Applicative m, MonadIO m, GmEnv m, GmLog m) => m [GHCOption] packageGhcOptions = do crdl <- cradle case cradleCabalFile crdl of - Just _ -> do + Just _ -> (Set.toList . Set.fromList . concat . map snd) `liftM` getGhcPkgOptions Nothing -> sandboxOpts crdl From 079c05ff17169f662846be83f66a3230812628e3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 20 May 2015 11:45:17 +0200 Subject: [PATCH 107/207] Fix a few warnings --- test/UtilsSpec.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs index 758b607..75f61cc 100644 --- a/test/UtilsSpec.hs +++ b/test/UtilsSpec.hs @@ -1,8 +1,6 @@ module UtilsSpec where -import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Utils -import TestUtils import Test.Hspec spec :: Spec From a2e4a5d683f7ea2d2f3b3aa603c42a6eabadfdb1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 20 May 2015 12:05:22 +0200 Subject: [PATCH 108/207] Revert "use standard findFile instead of hand-rolled one" This reverts commit b05509812754a409f3e3de2ae13a882507004cab. --- Language/Haskell/GhcMod/Target.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 7bcbb64..601707f 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -37,8 +37,10 @@ import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Utils import Data.Maybe +import Data.Monoid import Data.Either import Data.Foldable (foldrM) import Data.Traversable (traverse) @@ -313,7 +315,7 @@ resolveModule :: MonadIO m => resolveModule env _srcDirs (Right mn) = liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn resolveModule env srcDirs (Left fn') = liftIO $ do - mfn <- findFile srcDirs fn' + mfn <- findFile' srcDirs fn' case mfn of Nothing -> return Nothing Just fn'' -> do @@ -325,6 +327,9 @@ resolveModule env srcDirs (Left fn') = liftIO $ do case mmn of Nothing -> mkMainModulePath fn Just mn -> ModulePath mn fn + where + findFile' dirs file = + getFirst . mconcat <$> mapM (fmap First . mightExist . (file)) dirs resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [Either FilePath ModuleName] @@ -360,6 +365,7 @@ resolveGmComponents mumns cs = do else insertUpdated m c gmsPut s { gmComponents = m' } return m' + where foldrM' b fa f = foldrM f b fa insertUpdated m c = do From f779a778fb9d51dcd3c99c5a468e10bc7bf142b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 20 May 2015 12:05:43 +0200 Subject: [PATCH 109/207] spawnProcess doesn't exist before 7.8 --- src/GHCModi.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 602e3e1..3f5c90a 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -15,5 +15,6 @@ main :: IO () main = do args <- getArgs bindir <- getBinDir - h <- spawnProcess (bindir "ghc-mod") $ ["legacy-interactive"] ++ args + (_, _, _, h) <- + createProcess $ proc (bindir "ghc-mod") $ ["legacy-interactive"] ++ args exitWith =<< waitForProcess h From a1f6bf65822a46388f553278fdc0e5146ddb4990 Mon Sep 17 00:00:00 2001 From: Markus Hauck Date: Mon, 1 Dec 2014 10:17:51 +0100 Subject: [PATCH 110/207] Limit overlays to actual position of error Conflicts: elisp/ghc-check.el --- elisp/ghc-check.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el index 20de8b7..f90fded 100644 --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -177,10 +177,10 @@ nil does not display errors/warnings. (setq end (point))) (progn (forward-line (1- line)) - (skip-chars-forward " ") + (forward-char (1- coln)) (setq beg (point)) - (forward-line) - (setq end (1- (point)))))) + (skip-chars-forward "^[:space:]" (line-end-position)) + (setq end (point))))) (t (setq beg (point)) (forward-line) From b52c0a5d767282369f2748c5ec070b802ed8e23c Mon Sep 17 00:00:00 2001 From: Iku Iwasa Date: Fri, 22 May 2015 22:41:50 +0900 Subject: [PATCH 111/207] Fix typo to set process running status --- elisp/ghc-process.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 0519549..7ecfa34 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -34,7 +34,7 @@ (if ghc-process-running (error "ghc process already running") (progn - (when ghc-process-running t) + (setq ghc-process-running t) (if hook1 (funcall hook1)) (let* ((cbuf (current-buffer)) (name ghc-process-process-name) From 8cfa12c5cfb58116e3e58a015c8d9a6d5c1be6f9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 24 May 2015 21:58:24 +0200 Subject: [PATCH 112/207] Fix link in README --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 3eb99f4..0752888 100644 --- a/README.md +++ b/README.md @@ -62,7 +62,7 @@ each package database line is either a *path* to a package database, or `global` If you have any problems, suggestions, comments swing by [\#ghc-mod (web client)](https://kiwiirc.com/client/irc.freenode.org/ghc-mod) on Freenode. If you're reporting a bug please also create an issue -[here](https://github.com/DanielG/ghc-mod/issues) so we have a way to contact +[here](https://github.com/kazu-yamamoto/ghc-mod/issues) so we have a way to contact you if you don't have time to stay. Do hang around for a while if no one answers and repeat your question if you From 70a8a9a21e0f59fa634fe8f435bc4d723dbdf9da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 24 May 2015 22:41:00 +0200 Subject: [PATCH 113/207] Add compare-versions script --- scripts/compare-versions.sh | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) create mode 100644 scripts/compare-versions.sh diff --git a/scripts/compare-versions.sh b/scripts/compare-versions.sh new file mode 100644 index 0000000..a8a979b --- /dev/null +++ b/scripts/compare-versions.sh @@ -0,0 +1,36 @@ +################################################################################ +# # +# Find version differences in common packages of `ghc-pkg list` dumps. # +# # +# Copyright (C) 2015 Daniel Gröber # +# # +# Copying and distribution of this file, with or without modification, # +# are permitted in any medium without royalty provided the copyright # +# notice and this notice are preserved. This file is offered as-is, # +# without any warranty. # +# # +# Usage: sh compare-versions.sh FILE1 FILE2 # +# # +# Example: # +# sh compare-versions.sh =(ghc-pkg list) =(ssh some-host ghc-pkg list) # +# # +# Where `=(command)` is equivalent to: # +# `(tmp=$(mktemp); command > $tmp; echo $tmp)` # +# # +# # +# The output consists of lines in the format: # +# # +# VERSION1 is the version from FILE1 and VERSION2 is the version from FILE2 # +# # +################################################################################ + +t1=$(mktemp) +t2=$(mktemp) + +grep "^ " "$1" | sed 's/ *\(.*\)-\([0-9.]\+\)/\1 \2/' | sort > $t1 +grep "^ " "$2" | sed 's/ *\(.*\)-\([0-9.]\+\)/\1 \2/' | sort > $t2 + +comm -3 -2 $t1 $t2 | sort -k 1b,1 > $t1.diff +comm -3 -1 $t1 $t2 | sort -k 1b,1 > $t2.diff + +join $t1.diff $t2.diff | sort | uniq From fbe080085667bbcd2dddacb808366318dac7fb5a Mon Sep 17 00:00:00 2001 From: Gracjan Polak Date: Wed, 20 May 2015 08:38:29 +0200 Subject: [PATCH 114/207] Add haskell-mode dependency in pkg file --- elisp/ghc-pkg.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elisp/ghc-pkg.el b/elisp/ghc-pkg.el index 62e8c2e..79e57b8 100644 --- a/elisp/ghc-pkg.el +++ b/elisp/ghc-pkg.el @@ -2,4 +2,4 @@ "ghc" 2.0.0 "Sub mode for Haskell mode" - nil) + '((haskell-mode "13.0"))) From 7b3a84bc7475428087bed8ead5c3477b5796aba2 Mon Sep 17 00:00:00 2001 From: NightRa Date: Thu, 28 May 2015 00:22:04 +0300 Subject: [PATCH 115/207] Remove the data-default dependency --- ghc-mod.cabal | 1 - src/GHCMod.hs | 4 ---- 2 files changed, 5 deletions(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index bc5a01c..e6be847 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -160,7 +160,6 @@ Executable ghc-mod HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 , async - , data-default , directory , filepath , pretty diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 49e4099..35d58b9 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -8,7 +8,6 @@ import Control.Applicative import Control.Monad import Data.Typeable (Typeable) import Data.Version (showVersion) -import Data.Default import Data.List import Data.List.Split import Data.Char (isSpace) @@ -303,9 +302,6 @@ data InteractiveOptions = InteractiveOptions { ghcModExtensions :: Bool } -instance Default InteractiveOptions where - def = InteractiveOptions False - handler :: IO a -> IO a handler = flip catches $ [ Handler $ \(FatalError msg) -> exitError msg From 57e2c112dc8f52ee031062a44a1ade6ac2c27c22 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 1 Jun 2015 15:59:38 +0300 Subject: [PATCH 116/207] Use package dbs defined by current cradle when dealing with SymbolDBs --- Language/Haskell/GhcMod/Find.hs | 67 +++++++++++++++++---------------- src/Misc.hs | 2 +- 2 files changed, 36 insertions(+), 33 deletions(-) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 87fe3c6..039e83b 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-} module Language.Haskell.GhcMod.Find #ifndef SPEC @@ -16,21 +16,21 @@ module Language.Haskell.GhcMod.Find where import Control.Applicative ((<$>)) -import Control.Monad (when, void) +import Control.Monad (when, void, (<=<)) import Data.Function (on) import Data.List (groupBy, sort) -import Data.Maybe (fromMaybe) import qualified GHC as G import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.Gap (listVisibleModules) import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.Gap (listVisibleModules) +import Language.Haskell.GhcMod.World (timedPackageCaches) import Name (getOccString) import Module (moduleName) import System.Directory (doesFileExist, getModificationTime) -import System.FilePath ((), takeDirectory) +import System.FilePath (()) import System.IO #ifndef MIN_VERSION_containers @@ -50,14 +50,14 @@ import qualified Data.Map as M -- | Type of function and operation names. type Symbol = String -- | Database from 'Symbol' to \['ModuleString'\]. -data SymbolDb = SymbolDb { - table :: Map Symbol [ModuleString] - , packageCachePath :: FilePath +data SymbolDb = SymbolDb + { table :: Map Symbol [ModuleString] , symbolDbCachePath :: FilePath } deriving (Show) -isOutdated :: SymbolDb -> IO Bool -isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db +isOutdated :: (GmEnv m, IOish m) => SymbolDb -> m Bool +isOutdated db = + liftIO . (isOlderThan (symbolDbCachePath db) <=< timedPackageCaches) =<< cradle ---------------------------------------------------------------- @@ -72,7 +72,7 @@ lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String lookupSymbol sym db = convert' $ lookupSym sym db lookupSym :: Symbol -> SymbolDb -> [ModuleString] -lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db +lookupSym sym db = M.findWithDefault [] sym $ table db --------------------------------------------------------------- @@ -81,16 +81,16 @@ loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb = do ghcMod <- liftIO ghcModExecutable tmpdir <- cradleTempDir <$> cradle - file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] "" - !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) - return $ SymbolDb { - table = db - , packageCachePath = takeDirectory file packageCache + file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] "" + !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) + return $ SymbolDb + { table = db , symbolDbCachePath = file } where conv :: String -> (Symbol,[ModuleString]) conv = read + chop :: String -> String chop "" = "" chop xs = init xs @@ -102,13 +102,15 @@ loadSymbolDb = do -- The file name is printed. dumpSymbol :: IOish m => FilePath -> GhcModT m String -dumpSymbol dir = runGmPkgGhc $ do - let cache = dir symbolCacheFile - pkgdb = dir packageCache - - create <- liftIO $ cache `isOlderThan` pkgdb - when create $ (liftIO . writeSymbolCache cache) =<< getGlobalSymbolTable +dumpSymbol dir = do + crdl <- cradle + runGmPkgGhc $ do + create <- liftIO $ isOlderThan cache =<< timedPackageCaches crdl + when create $ + liftIO . writeSymbolCache cache =<< getGlobalSymbolTable return $ unlines [cache] + where + cache = dir symbolCacheFile writeSymbolCache :: FilePath -> [(Symbol,[ModuleString])] @@ -117,15 +119,16 @@ writeSymbolCache cache sm = void . withFile cache WriteMode $ \hdl -> mapM (hPrint hdl) sm -isOlderThan :: FilePath -> FilePath -> IO Bool -isOlderThan cache file = do - exist <- doesFileExist cache - if not exist then - return True - else do - tCache <- getModificationTime cache - tFile <- getModificationTime file - return $ tCache <= tFile -- including equal just in case +-- | Check whether given file is older than any file from the given set. +-- Returns True if given file does not exist. +isOlderThan :: FilePath -> [TimedFile] -> IO Bool +isOlderThan cache files = do + exist <- doesFileExist cache + if not exist + then return True + else do + tCache <- getModificationTime cache + return $ any (tCache <=) $ map tfTime files -- including equal just in case -- | Browsing all functions in all system modules. getGlobalSymbolTable :: LightGhc [(Symbol,[ModuleString])] diff --git a/src/Misc.hs b/src/Misc.hs index f7f622e..2c646c6 100644 --- a/src/Misc.hs +++ b/src/Misc.hs @@ -75,7 +75,7 @@ getDb (SymDbReq ref _) = do checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb checkDb (SymDbReq ref act) db = do - outdated <- liftIO $ isOutdated db + outdated <- isOutdated db if outdated then do -- async and wait here is unnecessary because this is essentially -- synchronous. But Async can be used a cache. From 73b98573f47cc0f21c1948875171644f30b8eb5a Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 1 Jun 2015 16:31:17 +0300 Subject: [PATCH 117/207] Remove unused extractParens function and its tests --- Language/Haskell/GhcMod/Utils.hs | 12 ------------ test/UtilsSpec.hs | 11 ----------- 2 files changed, 23 deletions(-) delete mode 100644 test/UtilsSpec.hs diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 91331b5..d562290 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -44,18 +44,6 @@ import Utils dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] -extractParens :: String -> String -extractParens str = extractParens' str 0 - where - extractParens' :: String -> Int -> String - extractParens' [] _ = [] - extractParens' (s:ss) level - | s `elem` "([{" = s : extractParens' ss (level+1) - | level == 0 = extractParens' ss 0 - | s `elem` "}])" && level == 1 = [s] - | s `elem` "}])" = s : extractParens' ss (level-1) - | otherwise = s : extractParens' ss level - withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a withDirectory_ dir action = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs deleted file mode 100644 index 75f61cc..0000000 --- a/test/UtilsSpec.hs +++ /dev/null @@ -1,11 +0,0 @@ -module UtilsSpec where - -import Language.Haskell.GhcMod.Utils -import Test.Hspec - -spec :: Spec -spec = do - describe "extractParens" $ do - it "extracts the part of a string surrounded by parentheses" $ do - extractParens "asdasdasd ( hello [ world ] )()() kljlkjlkjlk" `shouldBe` "( hello [ world ] )" - extractParens "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")][][]" `shouldBe` "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")]" From a23f1f3b753ee5facbd321afc6c68b53a9a216fb Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 1 Jun 2015 17:53:56 +0300 Subject: [PATCH 118/207] Improve findVar function --- Language/Haskell/GhcMod/FillSig.hs | 38 ++++++++++++++++-------------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 94f324c..f84675e 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -11,7 +11,7 @@ import Data.Char (isSymbol) import Data.Function (on) import Data.List (find, nub, sortBy) import qualified Data.Map as M -import Data.Maybe (isJust, catMaybes) +import Data.Maybe (catMaybes) import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) @@ -364,23 +364,25 @@ findVar :: GhcMonad m => DynFlags -> PprStyle -> G.TypecheckedModule -> G.TypecheckedSource -> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool)) findVar dflag style tcm tcs lineNo colNo = - let lst = sortBy (cmp `on` G.getLoc) $ - listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id] - in case lst of - e@(L _ (G.HsVar i)):others -> - do tyInfo <- Gap.getType tcm e - let name = getFnName dflag style i - if (name == "undefined" || head name == '_') && isJust tyInfo - then let Just (s,t) = tyInfo - b = case others of -- If inside an App, we need - -- parenthesis - [] -> False - L _ (G.HsApp (L _ a1) (L _ a2)):_ -> - isSearchedVar i a1 || isSearchedVar i a2 - _ -> False - in return $ Just (s, name, t, b) - else return Nothing - _ -> return Nothing + case lst of + e@(L _ (G.HsVar i)):others -> do + tyInfo <- Gap.getType tcm e + case tyInfo of + Just (span, typ) + | name == "undefined" || head name == '_' -> + return $ Just (span, name, typ, b) + where + name = getFnName dflag style i + -- If inside an App, we need parenthesis + b = case others of + L _ (G.HsApp (L _ a1) (L _ a2)):_ -> + isSearchedVar i a1 || isSearchedVar i a2 + _ -> False + _ -> return Nothing + _ -> return Nothing + where + lst :: [G.LHsExpr Id] + lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) infinitePrefixSupply :: String -> [String] infinitePrefixSupply "undefined" = repeat "undefined" From 4a9d5786815753ea0bf1fa1aee820272e4d9ffc6 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 1 Jun 2015 17:54:50 +0300 Subject: [PATCH 119/207] Improve style --- Language/Haskell/GhcMod/Boot.hs | 5 +- Language/Haskell/GhcMod/Browse.hs | 9 +- Language/Haskell/GhcMod/Convert.hs | 36 ++--- Language/Haskell/GhcMod/FillSig.hs | 75 +++++----- Language/Haskell/GhcMod/Find.hs | 56 ++++---- Language/Haskell/GhcMod/Info.hs | 53 +++---- Language/Haskell/GhcMod/Types.hs | 213 +++++++++++++++-------------- Language/Haskell/GhcMod/Utils.hs | 79 +++++------ 8 files changed, 263 insertions(+), 263 deletions(-) diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs index 7e261d5..70c77b6 100644 --- a/Language/Haskell/GhcMod/Boot.hs +++ b/Language/Haskell/GhcMod/Boot.hs @@ -9,8 +9,9 @@ import Language.Haskell.GhcMod.Modules -- | Printing necessary information for front-end booting. boot :: IOish m => GhcModT m String -boot = concat <$> sequence [modules, languages, flags, - concat <$> mapM browse preBrowsedModules] +boot = concat <$> sequence ms + where + ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules] preBrowsedModules :: [String] preBrowsedModules = [ diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index bc45f82..f691464 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -48,7 +48,7 @@ browse pkgmdl = do tryModuleInfo m = fromJust <$> G.getModuleInfo m - (mpkg,mdl) = splitPkgMdl pkgmdl + (mpkg, mdl) = splitPkgMdl pkgmdl mdlname = G.mkModuleName mdl mpkgid = mkFastString <$> mpkg @@ -59,9 +59,10 @@ browse pkgmdl = do -- >>> splitPkgMdl "Prelude" -- (Nothing,"Prelude") splitPkgMdl :: String -> (Maybe String,String) -splitPkgMdl pkgmdl = case break (==':') pkgmdl of - (mdl,"") -> (Nothing,mdl) - (pkg,_:mdl) -> (Just pkg,mdl) +splitPkgMdl pkgmdl = + case break (==':') pkgmdl of + (mdl, "") -> (Nothing, mdl) + (pkg, _:mdl) -> (Just pkg, mdl) -- Haskell 2010: -- small -> ascSmall | uniSmall | _ diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 248adde..39bb426 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -27,7 +27,7 @@ convert' :: (ToString a, IOish m, GmEnv m) => a -> m String convert' x = flip convert x <$> options convert :: ToString a => Options -> a -> String -convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n" +convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n" convert opt@Options { outputStyle = PlainStyle } x | str == "\n" = "" | otherwise = str @@ -35,8 +35,8 @@ convert opt@Options { outputStyle = PlainStyle } x str = toPlain opt x "\n" class ToString a where - toLisp :: Options -> a -> Builder - toPlain :: Options -> a -> Builder + toLisp :: Options -> a -> Builder + toPlain :: Options -> a -> Builder lineSep :: Options -> String lineSep opt = interpret lsep @@ -51,8 +51,8 @@ lineSep opt = interpret lsep -- >>> toPlain defaultOptions "foo" "" -- "foo" instance ToString String where - toLisp opt = quote opt - toPlain opt = replace '\n' (lineSep opt) + toLisp opt = quote opt + toPlain opt = replace '\n' (lineSep opt) -- | -- @@ -61,8 +61,8 @@ instance ToString String where -- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" -- "foo\nbar\nbaz" instance ToString [String] where - toLisp opt = toSexp1 opt - toPlain opt = inter '\n' . map (toPlain opt) + toLisp opt = toSexp1 opt + toPlain opt = inter '\n' . map (toPlain opt) -- | -- @@ -72,23 +72,23 @@ instance ToString [String] where -- >>> toPlain defaultOptions inp "" -- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" instance ToString [((Int,Int,Int,Int),String)] where - toLisp opt = toSexp2 . map toS - where - toS x = ('(' :) . tupToString opt x . (')' :) - toPlain opt = inter '\n' . map (tupToString opt) + toLisp opt = toSexp2 . map toS + where + toS x = ('(' :) . tupToString opt x . (')' :) + toPlain opt = inter '\n' . map (tupToString opt) instance ToString ((Int,Int,Int,Int),String) where - toLisp opt x = ('(' :) . tupToString opt x . (')' :) - toPlain opt x = tupToString opt x + toLisp opt x = ('(' :) . tupToString opt x . (')' :) + toPlain opt x = tupToString opt x instance ToString ((Int,Int,Int,Int),[String]) where - toLisp opt (x,s) = ('(' :) . fourIntsToString opt x . - (' ' :) . toLisp opt s . (')' :) - toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s + toLisp opt (x,s) = ('(' :) . fourIntsToString opt x . + (' ' :) . toLisp opt s . (')' :) + toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s instance ToString (String, (Int,Int,Int,Int),[String]) where - toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y] - toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y] + toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y] + toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y] toSexp1 :: Options -> [String] -> Builder toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index f84675e..ecfc93d 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -79,17 +79,14 @@ sig file lineNo colNo = Signature loc names ty -> ("function", fourInts loc, map (initialBody dflag style ty) names) - InstanceDecl loc cls -> let - body x = initialBody dflag style (G.idType x) x - in - ("instance", fourInts loc, body `map` Ty.classMethods cls) + InstanceDecl loc cls -> + let body x = initialBody dflag style (G.idType x) x + in ("instance", fourInts loc, body `map` Ty.classMethods cls) TyFamDecl loc name flavour vars -> let (rTy, initial) = initialTyFamString flavour body = initialFamBody dflag style name vars - in (rTy, fourInts loc, [initial ++ body]) - - + in (rTy, fourInts loc, [initial ++ body]) where fallback (SomeException _) = do opt <- options @@ -244,9 +241,11 @@ initialHead1 :: String -> [FnArg] -> [String] -> String initialHead1 fname args elts = case initialBodyArgs1 args elts of [] -> fname - arglist -> if isSymbolName fname - then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) - else fname ++ " " ++ unwords arglist + arglist + | isSymbolName fname -> + head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) + | otherwise -> + fname ++ " " ++ unwords arglist initialBodyArgs1 :: [FnArg] -> [String] -> [String] initialBodyArgs1 args elts = take (length args) elts @@ -338,39 +337,45 @@ refine :: IOish m -> Expression -- ^ A Haskell expression. -> GhcModT m String refine file lineNo colNo expr = - ghandle handler $ runGmlT' [Left file] deferErrors $ do - opt <- options - style <- getStyle - dflag <- G.getSessionDynFlags - modSum <- Gap.fileModSummary file - p <- G.parseModule modSum - tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - ety <- G.exprType expr - whenFound opt (findVar dflag style tcm tcs lineNo colNo) $ - \(loc, name, rty, paren) -> - let eArgs = getFnArgs ety - rArgs = getFnArgs rty - diffArgs' = length eArgs - length rArgs - diffArgs = if diffArgs' < 0 then 0 else diffArgs' - iArgs = take diffArgs eArgs - text = initialHead1 expr iArgs (infinitePrefixSupply name) - in (fourInts loc, doParen paren text) - - where - handler (SomeException _) = emptyResult =<< options + ghandle handler $ + runGmlT' [Left file] deferErrors $ do + opt <- options + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- Gap.fileModSummary file + p <- G.parseModule modSum + tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p + ety <- G.exprType expr + whenFound opt (findVar dflag style tcm tcs lineNo colNo) $ + \(loc, name, rty, paren) -> + let eArgs = getFnArgs ety + rArgs = getFnArgs rty + diffArgs' = length eArgs - length rArgs + diffArgs = if diffArgs' < 0 then 0 else diffArgs' + iArgs = take diffArgs eArgs + text = initialHead1 expr iArgs (infinitePrefixSupply name) + in (fourInts loc, doParen paren text) + where + handler (SomeException _) = emptyResult =<< options -- Look for the variable in the specified position -findVar :: GhcMonad m => DynFlags -> PprStyle - -> G.TypecheckedModule -> G.TypecheckedSource - -> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool)) +findVar + :: GhcMonad m + => DynFlags + -> PprStyle + -> G.TypecheckedModule + -> G.TypecheckedSource + -> Int + -> Int + -> m (Maybe (SrcSpan, String, Type, Bool)) findVar dflag style tcm tcs lineNo colNo = case lst of e@(L _ (G.HsVar i)):others -> do tyInfo <- Gap.getType tcm e case tyInfo of - Just (span, typ) + Just (s, typ) | name == "undefined" || head name == '_' -> - return $ Just (span, name, typ, b) + return $ Just (s, name, typ, b) where name = getFnName dflag style i -- If inside an App, we need parenthesis diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 039e83b..d361f20 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -2,8 +2,7 @@ module Language.Haskell.GhcMod.Find #ifndef SPEC - ( - Symbol + ( Symbol , SymbolDb , loadSymbolDb , lookupSymbol @@ -33,17 +32,8 @@ import System.Directory (doesFileExist, getModificationTime) import System.FilePath (()) import System.IO -#ifndef MIN_VERSION_containers -#define MIN_VERSION_containers(x,y,z) 1 -#endif - -#if MIN_VERSION_containers(0,5,0) import Data.Map (Map) import qualified Data.Map as M -#else -import Data.Map (Map) -import qualified Data.Map as M -#endif ---------------------------------------------------------------- @@ -79,16 +69,16 @@ lookupSym sym db = M.findWithDefault [] sym $ table db -- | Loading a file and creates 'SymbolDb'. loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb = do - ghcMod <- liftIO ghcModExecutable - tmpdir <- cradleTempDir <$> cradle - file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] "" - !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) - return $ SymbolDb - { table = db - , symbolDbCachePath = file - } + ghcMod <- liftIO ghcModExecutable + tmpdir <- cradleTempDir <$> cradle + file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] "" + !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) + return $ SymbolDb + { table = db + , symbolDbCachePath = file + } where - conv :: String -> (Symbol,[ModuleString]) + conv :: String -> (Symbol, [ModuleString]) conv = read chop :: String -> String chop "" = "" @@ -113,11 +103,11 @@ dumpSymbol dir = do cache = dir symbolCacheFile writeSymbolCache :: FilePath - -> [(Symbol,[ModuleString])] + -> [(Symbol, [ModuleString])] -> IO () writeSymbolCache cache sm = void . withFile cache WriteMode $ \hdl -> - mapM (hPrint hdl) sm + mapM (hPrint hdl) sm -- | Check whether given file is older than any file from the given set. -- Returns True if given file does not exist. @@ -131,24 +121,24 @@ isOlderThan cache files = do return $ any (tCache <=) $ map tfTime files -- including equal just in case -- | Browsing all functions in all system modules. -getGlobalSymbolTable :: LightGhc [(Symbol,[ModuleString])] +getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])] getGlobalSymbolTable = do - df <- G.getSessionDynFlags - let mods = listVisibleModules df - moduleInfos <- mapM G.getModuleInfo mods - return $ collectModules - $ extractBindings `concatMap` (moduleInfos `zip` mods) + df <- G.getSessionDynFlags + let mods = listVisibleModules df + moduleInfos <- mapM G.getModuleInfo mods + return $ collectModules + $ extractBindings `concatMap` (moduleInfos `zip` mods) extractBindings :: (Maybe G.ModuleInfo, G.Module) -> [(Symbol, ModuleString)] -extractBindings (Nothing,_) = [] -extractBindings (Just inf,mdl) = - map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names +extractBindings (Nothing, _) = [] +extractBindings (Just inf, mdl) = + map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names where names = G.modInfoExports inf -collectModules :: [(Symbol,ModuleString)] - -> [(Symbol,[ModuleString])] +collectModules :: [(Symbol, ModuleString)] + -> [(Symbol, [ModuleString])] collectModules = map tieup . groupBy ((==) `on` fst) . sort where tieup x = (head (map fst x), map snd x) diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index d109f02..6344a5d 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -30,20 +30,21 @@ info :: IOish m -> Expression -- ^ A Haskell expression. -> GhcModT m String info file expr = - ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $ - convert <$> options <*> body + ghandle handler $ + runGmlT' [Left file] deferErrors $ + withContext $ + convert <$> options <*> body where handler (SomeException ex) = do - gmLog GmException "info" $ - text "" $$ nest 4 (showDoc ex) - convert' "Cannot show info" + gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex) + convert' "Cannot show info" + body :: GhcMonad m => m String body = do - sdoc <- Gap.infoThing expr - st <- getStyle - dflag <- G.getSessionDynFlags - return $ showPage dflag st sdoc - + sdoc <- Gap.infoThing expr + st <- getStyle + dflag <- G.getSessionDynFlags + return $ showPage dflag st sdoc ---------------------------------------------------------------- @@ -54,14 +55,14 @@ types :: IOish m -> Int -- ^ Column number. -> GhcModT m String types file lineNo colNo = - ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $ do - crdl <- cradle - modSum <- Gap.fileModSummary (cradleCurrentDir crdl file) + ghandle handler $ + runGmlT' [Left file] deferErrors $ + withContext $ do + crdl <- cradle + modSum <- Gap.fileModSummary (cradleCurrentDir crdl file) srcSpanTypes <- getSrcSpanType modSum lineNo colNo - - dflag <- G.getSessionDynFlags - st <- getStyle - + dflag <- G.getSessionDynFlags + st <- getStyle convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes where handler (SomeException ex) = do @@ -70,12 +71,12 @@ types file lineNo colNo = getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] getSrcSpanType modSum lineNo colNo = do - p <- G.parseModule modSum - tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] - es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id] - ps = listifySpans tcs (lineNo, colNo) :: [LPat Id] - bts <- mapM (getType tcm) bs - ets <- mapM (getType tcm) es - pts <- mapM (getType tcm) ps - return $ catMaybes $ concat [ets, bts, pts] + p <- G.parseModule modSum + tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p + let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] + es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id] + ps = listifySpans tcs (lineNo, colNo) :: [LPat Id] + bts <- mapM (getType tcm) bs + ets <- mapM (getType tcm) es + pts <- mapM (getType tcm) ps + return $ catMaybes $ concat [ets, bts, pts] diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index b1be7f0..e5e0909 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -50,7 +50,7 @@ type MonadIOC m = (MTL.MonadIO m) #endif class MonadIOC m => MonadIO m where - liftIO :: IO a -> m a + liftIO :: IO a -> m a -- | Output style. data OutputStyle = LispStyle -- ^ S expression style. @@ -83,21 +83,20 @@ data Options = Options { , hlintOpts :: [String] } deriving (Show) - -- | A default 'Options'. defaultOptions :: Options defaultOptions = Options { - outputStyle = PlainStyle - , lineSeparator = LineSeparator "\0" - , logLevel = GmWarning - , ghcProgram = "ghc" - , ghcPkgProgram = "ghc-pkg" - , cabalProgram = "cabal" - , ghcUserOptions= [] - , operators = False - , detailed = False - , qualified = False - , hlintOpts = [] + outputStyle = PlainStyle + , lineSeparator = LineSeparator "\0" + , logLevel = GmWarning + , ghcProgram = "ghc" + , ghcPkgProgram = "ghc-pkg" + , cabalProgram = "cabal" + , ghcUserOptions = [] + , operators = False + , detailed = False + , qualified = False + , hlintOpts = [] } ---------------------------------------------------------------- @@ -113,7 +112,7 @@ data Cradle = Cradle { -- | The file name of the found cabal file. , cradleCabalFile :: Maybe FilePath -- | Package database stack - , cradlePkgDbStack :: [GhcPkgDb] + , cradlePkgDbStack :: [GhcPkgDb] } deriving (Eq, Show) ---------------------------------------------------------------- @@ -122,7 +121,7 @@ data Cradle = Cradle { data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show) -- | A single GHC command line option. -type GHCOption = String +type GHCOption = String -- | An include directory for modules. type IncludeDir = FilePath @@ -131,28 +130,28 @@ type IncludeDir = FilePath type PackageBaseName = String -- | A package version. -type PackageVersion = String +type PackageVersion = String -- | A package id. -type PackageId = String +type PackageId = String -- | A package's name, verson and id. -type Package = (PackageBaseName, PackageVersion, PackageId) +type Package = (PackageBaseName, PackageVersion, PackageId) pkgName :: Package -> PackageBaseName -pkgName (n,_,_) = n +pkgName (n, _, _) = n pkgVer :: Package -> PackageVersion -pkgVer (_,v,_) = v +pkgVer (_, v, _) = v pkgId :: Package -> PackageId -pkgId (_,_,i) = i +pkgId (_, _, i) = i showPkg :: Package -> String -showPkg (n,v,_) = intercalate "-" [n,v] +showPkg (n, v, _) = intercalate "-" [n, v] showPkgId :: Package -> String -showPkgId (n,v,i) = intercalate "-" [n,v,i] +showPkgId (n, v, i) = intercalate "-" [n, v, i] -- | Haskell expression. type Expression = String @@ -163,131 +162,133 @@ type ModuleString = String -- | A Module type Module = [String] -data GmLogLevel = GmSilent - | GmPanic - | GmException - | GmError - | GmWarning - | GmInfo - | GmDebug - deriving (Eq, Ord, Enum, Bounded, Show, Read) +data GmLogLevel = + GmSilent + | GmPanic + | GmException + | GmError + | GmWarning + | GmInfo + | GmDebug + deriving (Eq, Ord, Enum, Bounded, Show, Read) -- | Collection of packages type PkgDb = (Map Package PackageConfig) data GmModuleGraph = GmModuleGraph { - gmgGraph :: Map ModulePath (Set ModulePath) - } deriving (Eq, Ord, Show, Read, Generic, Typeable) + gmgGraph :: Map ModulePath (Set ModulePath) + } deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Serialize GmModuleGraph where - put GmModuleGraph {..} = let - mpim :: Map ModulePath Integer - graph :: Map Integer (Set Integer) + put GmModuleGraph {..} = put (mpim, graph) + where + mpim :: Map ModulePath Integer + mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..] + graph :: Map Integer (Set Integer) + graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph + mpToInt :: ModulePath -> Integer + mpToInt mp = fromJust $ Map.lookup mp mpim - mpim = Map.fromList $ - (Map.keys gmgGraph) `zip` [0..] - mpToInt :: ModulePath -> Integer - mpToInt mp = fromJust $ Map.lookup mp mpim - - graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph - in put (mpim, graph) - - get = do - (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get - let - swapMap = Map.fromList . map swap . Map.toList - swap (a,b) = (b,a) - impm = swapMap mpim - intToMp i = fromJust $ Map.lookup i impm - mpGraph :: Map ModulePath (Set ModulePath) - mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph - return $ GmModuleGraph mpGraph + get = do + (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get + let impm = swapMap mpim + intToMp i = fromJust $ Map.lookup i impm + mpGraph :: Map ModulePath (Set ModulePath) + mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph + return $ GmModuleGraph mpGraph + where + swapMap :: (Ord k, Ord v) => Map k v -> Map v k + swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList instance Monoid GmModuleGraph where - mempty = GmModuleGraph mempty - mappend (GmModuleGraph a) (GmModuleGraph a') = - GmModuleGraph (Map.unionWith Set.union a a') + mempty = GmModuleGraph mempty + mappend (GmModuleGraph a) (GmModuleGraph a') = + GmModuleGraph (Map.unionWith Set.union a a') data GmComponentType = GMCRaw | GMCResolved data GmComponent (t :: GmComponentType) eps = GmComponent { - gmcHomeModuleGraph :: GmModuleGraph, - gmcName :: ChComponentName, - gmcGhcOpts :: [GHCOption], - gmcGhcPkgOpts :: [GHCOption], - gmcGhcSrcOpts :: [GHCOption], - gmcGhcLangOpts :: [GHCOption], - gmcRawEntrypoints :: ChEntrypoint, - gmcEntrypoints :: eps, - gmcSourceDirs :: [FilePath] - } deriving (Eq, Ord, Show, Read, Generic, Functor) + gmcHomeModuleGraph :: GmModuleGraph + , gmcName :: ChComponentName + , gmcGhcOpts :: [GHCOption] + , gmcGhcPkgOpts :: [GHCOption] + , gmcGhcSrcOpts :: [GHCOption] + , gmcGhcLangOpts :: [GHCOption] + , gmcRawEntrypoints :: ChEntrypoint + , gmcEntrypoints :: eps + , gmcSourceDirs :: [FilePath] + } deriving (Eq, Ord, Show, Read, Generic, Functor) instance Serialize eps => Serialize (GmComponent t eps) data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath } - deriving (Eq, Ord, Show, Read, Generic, Typeable) + deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Serialize ModulePath instance Serialize ModuleName where - get = mkModuleName <$> get - put mn = put (moduleNameString mn) + get = mkModuleName <$> get + put mn = put (moduleNameString mn) instance Show ModuleName where - show mn = "ModuleName " ++ show (moduleNameString mn) + show mn = "ModuleName " ++ show (moduleNameString mn) instance Read ModuleName where - readsPrec d r = readParen (d > app_prec) - (\r' -> [(mkModuleName m,t) | - ("ModuleName",s) <- lex r', - (m,t) <- readsPrec (app_prec+1) s]) r - where app_prec = 10 + readsPrec d = + readParen + (d > app_prec) + (\r' -> [ (mkModuleName m, t) + | ("ModuleName", s) <- lex r' + , (m, t) <- readsPrec (app_prec + 1) s + ]) + where + app_prec = 10 data GhcModError - = GMENoMsg - -- ^ Unknown error + = GMENoMsg + -- ^ Unknown error - | GMEString String - -- ^ Some Error with a message. These are produced mostly by - -- 'fail' calls on GhcModT. + | GMEString String + -- ^ Some Error with a message. These are produced mostly by + -- 'fail' calls on GhcModT. - | GMECabalConfigure GhcModError - -- ^ Configuring a cabal project failed. + | GMECabalConfigure GhcModError + -- ^ Configuring a cabal project failed. - | GMECabalFlags GhcModError - -- ^ Retrieval of the cabal configuration flags failed. + | GMECabalFlags GhcModError + -- ^ Retrieval of the cabal configuration flags failed. - | GMECabalComponent ChComponentName - -- ^ Cabal component could not be found + | GMECabalComponent ChComponentName + -- ^ Cabal component could not be found - | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)] - -- ^ Could not find a consistent component assignment for modules + | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)] + -- ^ Could not find a consistent component assignment for modules - | GMEProcess String [String] (Either (String, String, Int) GhcModError) - -- ^ Launching an operating system process failed. Fields in - -- order: command, arguments, (stdout, stderr, exitcode) + | GMEProcess String [String] (Either (String, String, Int) GhcModError) + -- ^ Launching an operating system process failed. Fields in + -- order: command, arguments, (stdout, stderr, exitcode) - | GMENoCabalFile - -- ^ No cabal file found. + | GMENoCabalFile + -- ^ No cabal file found. - | GMETooManyCabalFiles [FilePath] - -- ^ Too many cabal files found. + | GMETooManyCabalFiles [FilePath] + -- ^ Too many cabal files found. - | GMECabalStateFile GMConfigStateFileError - -- ^ Reading Cabal's state configuration file falied somehow. - deriving (Eq,Show,Typeable) + | GMECabalStateFile GMConfigStateFileError + -- ^ Reading Cabal's state configuration file falied somehow. + deriving (Eq,Show,Typeable) instance Error GhcModError where - noMsg = GMENoMsg - strMsg = GMEString + noMsg = GMENoMsg + strMsg = GMEString instance Exception GhcModError data GMConfigStateFileError - = GMConfigStateFileNoHeader - | GMConfigStateFileBadHeader - | GMConfigStateFileNoParse - | GMConfigStateFileMissing --- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) + = GMConfigStateFileNoHeader + | GMConfigStateFileBadHeader + | GMConfigStateFileNoParse + | GMConfigStateFileMissing +-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) deriving (Eq, Show, Read, Typeable) diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index d562290..a9a092b 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -15,26 +15,26 @@ -- along with this program. If not, see . {-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} + module Language.Haskell.GhcMod.Utils ( module Language.Haskell.GhcMod.Utils , module Utils , readProcess ) where -import Control.Arrow import Control.Applicative import Data.Char +import Exception import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Monad.Types -import Exception import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist, - getTemporaryDirectory, canonicalizePath, doesFileExist) -import System.Process (readProcess) -import System.Directory () + getTemporaryDirectory, canonicalizePath) +import System.Environment import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators, ()) import System.IO.Temp (createTempDirectory) -import System.Environment +import System.Process (readProcess) import Text.Printf import Paths_ghc_mod (getLibexecDir) @@ -46,25 +46,28 @@ dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a withDirectory_ dir action = - gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) - (\_ -> liftIO (setCurrentDirectory dir) >> action) + gbracket + (liftIO getCurrentDirectory) + (liftIO . setCurrentDirectory) + (\_ -> liftIO (setCurrentDirectory dir) >> action) uniqTempDirName :: FilePath -> FilePath -uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++) - $ map escapeDriveChar *** map escapePathChar - $ splitDrive dir - where +uniqTempDirName dir = + "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path + where + (drive, path) = splitDrive dir + escapeDriveChar :: Char -> Char escapeDriveChar c - | isAlphaNum c = c - | otherwise = '-' - + | isAlphaNum c = c + | otherwise = '-' + escapePathChar :: Char -> Char escapePathChar c - | c `elem` pathSeparators = '-' - | otherwise = c + | c `elem` pathSeparators = '-' + | otherwise = c newTempDir :: FilePath -> IO FilePath newTempDir dir = - flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory + flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory whenM :: IO Bool -> IO () -> IO () whenM mb ma = mb >>= flip when ma @@ -82,21 +85,21 @@ ghcModExecutable = fmap ( "dist/build/ghc-mod/ghc-mod") getCurrentDirectory findLibexecExe :: String -> IO FilePath findLibexecExe "cabal-helper-wrapper" = do - libexecdir <- getLibexecDir - let exeName = "cabal-helper-wrapper" - exe = libexecdir exeName + libexecdir <- getLibexecDir + let exeName = "cabal-helper-wrapper" + exe = libexecdir exeName - exists <- doesFileExist exe + exists <- doesFileExist exe - if exists - then return exe - else do - mdir <- tryFindGhcModTreeDataDir - case mdir of - Nothing -> - error $ libexecNotExitsError exeName libexecdir - Just dir -> - return $ dir "dist" "build" exeName exeName + if exists + then return exe + else do + mdir <- tryFindGhcModTreeDataDir + case mdir of + Nothing -> + error $ libexecNotExitsError exeName libexecdir + Just dir -> + return $ dir "dist" "build" exeName exeName findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe libexecNotExitsError :: String -> FilePath -> String @@ -119,22 +122,20 @@ tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath) tryFindGhcModTreeLibexecDir = do exe <- getExecutablePath' dir <- case takeFileName exe of - "ghc" -> do -- we're probably in ghci; try CWD - getCurrentDirectory - _ -> - return $ (!!4) $ iterate takeDirectory exe + "ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD + _ -> return $ (!!4) $ iterate takeDirectory exe exists <- doesFileExist $ dir "ghc-mod.cabal" return $ if exists - then Just dir - else Nothing + then Just dir + else Nothing tryFindGhcModTreeDataDir :: IO (Maybe FilePath) tryFindGhcModTreeDataDir = do dir <- (!!4) . iterate takeDirectory <$> getExecutablePath' exists <- doesFileExist $ dir "ghc-mod.cabal" return $ if exists - then Just dir - else Nothing + then Just dir + else Nothing readLibExecProcess' :: (MonadIO m, ExceptionMonad m) => String -> [String] -> m String From 6a65701397b6e1a642708e63ce5bed0f2ba68343 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 1 Jun 2015 18:07:04 +0300 Subject: [PATCH 120/207] Remove unused Module type --- Language/Haskell/GhcMod/Types.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index e5e0909..e431806 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -159,9 +159,6 @@ type Expression = String -- | Module name. type ModuleString = String --- | A Module -type Module = [String] - data GmLogLevel = GmSilent | GmPanic From 7b6eb55b11b5813a30077482d09366c0ec4563b6 Mon Sep 17 00:00:00 2001 From: Sergey Vinokurov Date: Mon, 1 Jun 2015 18:10:37 +0300 Subject: [PATCH 121/207] Transform ModuleString and Expression type synonyms into newtypes --- Language/Haskell/GhcMod.hs | 2 +- Language/Haskell/GhcMod/Browse.hs | 2 +- Language/Haskell/GhcMod/Convert.hs | 4 ++++ Language/Haskell/GhcMod/FillSig.hs | 2 +- Language/Haskell/GhcMod/Find.hs | 5 +++-- Language/Haskell/GhcMod/Gap.hs | 6 ++++-- Language/Haskell/GhcMod/Types.hs | 6 ++++-- src/GHCMod.hs | 10 +++++----- test/FindSpec.hs | 2 +- test/InfoSpec.hs | 6 +++--- 10 files changed, 27 insertions(+), 18 deletions(-) diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 0b358a6..763384e 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -17,7 +17,7 @@ module Language.Haskell.GhcMod ( , gmLog -- * Types , ModuleString - , Expression + , Expression(..) , GhcPkgDb , Symbol , SymbolDb diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index f691464..19a4b02 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -27,7 +27,7 @@ import Exception (ExceptionMonad, ghandle) -- If 'detailed' is 'True', their types are also obtained. -- If 'operators' is 'True', operators are also returned. browse :: forall m. IOish m - => ModuleString -- ^ A module name. (e.g. \"Data.List\") + => String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude") -> GhcModT m String browse pkgmdl = do convert' . sort =<< go diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 39bb426..a679aa0 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -64,6 +64,10 @@ instance ToString [String] where toLisp opt = toSexp1 opt toPlain opt = inter '\n' . map (toPlain opt) +instance ToString [ModuleString] where + toLisp opt = toLisp opt . map getModuleString + toPlain opt = toPlain opt . map getModuleString + -- | -- -- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index ecfc93d..b1700eb 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -336,7 +336,7 @@ refine :: IOish m -> Int -- ^ Column number. -> Expression -- ^ A Haskell expression. -> GhcModT m String -refine file lineNo colNo expr = +refine file lineNo colNo (Expression expr) = ghandle handler $ runGmlT' [Left file] deferErrors $ do opt <- options diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index d361f20..aee450c 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -133,9 +133,10 @@ extractBindings :: (Maybe G.ModuleInfo, G.Module) -> [(Symbol, ModuleString)] extractBindings (Nothing, _) = [] extractBindings (Just inf, mdl) = - map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names + map (\name -> (getOccString name, modStr)) names where - names = G.modInfoExports inf + names = G.modInfoExports inf + modStr = ModuleString $ moduleNameString $ moduleName mdl collectModules :: [(Symbol, ModuleString)] -> [(Symbol, [ModuleString])] diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index f76c7ce..4719185 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -103,6 +103,8 @@ import Parser import SrcLoc import Packages +import Language.Haskell.GhcMod.Types (Expression(..)) + ---------------------------------------------------------------- ---------------------------------------------------------------- -- @@ -325,8 +327,8 @@ filterOutChildren get_thing xs where implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] -infoThing :: GhcMonad m => String -> m SDoc -infoThing str = do +infoThing :: GhcMonad m => Expression -> m SDoc +infoThing (Expression str) = do names <- parseName str #if __GLASGOW_HASKELL__ >= 708 mb_stuffs <- mapM (getInfo False) names diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index e431806..b33c01a 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -154,10 +154,12 @@ showPkgId :: Package -> String showPkgId (n, v, i) = intercalate "-" [n, v, i] -- | Haskell expression. -type Expression = String +newtype Expression = Expression { getExpression :: String } + deriving (Show, Eq, Ord) -- | Module name. -type ModuleString = String +newtype ModuleString = ModuleString { getModuleString :: String } + deriving (Show, Read, Eq, Ord) data GmLogLevel = GmSilent diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 49e4099..b029036 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -517,8 +517,8 @@ autoCmd = withParseCmd [] $ locAction "auto" auto refineCmd = withParseCmd [] $ locAction' "refine" refine infoCmd = withParseCmd [] $ action - where action [file,_,expr] = info file expr - action [file,expr] = info file expr + where action [file,_,expr] = info file $ Expression expr + action [file,expr] = info file $ Expression expr action _ = throw $ InvalidCommandLine (Left "info") legacyInteractiveCmd = withParseCmd [] $ \[] -> legacyInteractive >> return "" @@ -532,9 +532,9 @@ locAction _ action [file,_,line,col] = action file (read line) (read col) locAction _ action [file, line,col] = action file (read line) (read col) locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd) -locAction' :: String -> (String -> Int -> Int -> String -> a) -> [String] -> a -locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) expr -locAction' _ action [f, line,col,expr] = action f (read line) (read col) expr +locAction' :: String -> (String -> Int -> Int -> Expression -> a) -> [String] -> a +locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) (Expression expr) +locAction' _ action [f, line,col,expr] = action f (read line) (read col) (Expression expr) locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd) diff --git a/test/FindSpec.hs b/test/FindSpec.hs index 3560997..55e84df 100644 --- a/test/FindSpec.hs +++ b/test/FindSpec.hs @@ -9,4 +9,4 @@ spec = do describe "db <- loadSymbolDb" $ do it "lookupSymbol' db \"head\" contains at least `Data.List'" $ do db <- runD loadSymbolDb - lookupSym "head" db `shouldContain` ["Data.List"] + lookupSym "head" db `shouldContain` [ModuleString "Data.List"] diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs index 091bbae..6a5296c 100644 --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -34,17 +34,17 @@ spec = do describe "info" $ do it "works for non exported functions" $ do let tdir = "test/data/non-exported" - res <- runD' tdir $ info "Fib.hs" "fib" + res <- runD' tdir $ info "Fib.hs" $ Expression "fib" res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`) it "works with a module using TemplateHaskell" $ do let tdir = "test/data/template-haskell" - res <- runD' tdir $ info "Bar.hs" "foo" + res <- runD' tdir $ info "Bar.hs" $ Expression "foo" res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`) it "works with a module that imports another module using TemplateHaskell" $ do let tdir = "test/data/template-haskell" - res <- runD' tdir $ info "ImportsTH.hs" "bar" + res <- runD' tdir $ info "ImportsTH.hs" $ Expression "bar" res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`) getDistDir :: IO FilePath From e6427ef643bf6cb48462a181a7b16ce8942d2f35 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 27 May 2015 23:25:39 +0200 Subject: [PATCH 122/207] Update HCAR entry --- ghcmodHappyHaskellProgram-Dg.tex | 51 ++++++++++++++++++++++++++++++++ hcar-ghc-mod.tex | 26 ---------------- 2 files changed, 51 insertions(+), 26 deletions(-) create mode 100644 ghcmodHappyHaskellProgram-Dg.tex delete mode 100644 hcar-ghc-mod.tex diff --git a/ghcmodHappyHaskellProgram-Dg.tex b/ghcmodHappyHaskellProgram-Dg.tex new file mode 100644 index 0000000..7af3027 --- /dev/null +++ b/ghcmodHappyHaskellProgram-Dg.tex @@ -0,0 +1,51 @@ +% ghcmodHappyHaskellProgram-Dg.tex +\begin{hcarentry}[updated]{ghc-mod --- Happy Haskell Programming} +\report{Daniel Gr\"ober}%05/15 +\status{open source, actively developed} +\makeheader + +\texttt{ghc-mod} is both a backend program for enhancing editors and other kinds +of development environments with support for Haskell, and an Emacs package +providing the user facing functionality, internally called \texttt{ghc} for +historical reasons. Other people have also developed numerous front ends for Vim +and there also exist some for Atom and a few other proprietary editors. + +After a period of declining activity, development has been picking up pace again +since Daniel Gr\"ober took over as maintainer. Most changes during versions +5.0.0--5.2.1.2 consisted only of fixes and internal cleanup work, but for the +past four months, vastly improved Cabal support has been in the works and is now +starting to stabilize. + +This work is a major step forward in terms of how well ghc-mod's suggestions +reflect what \texttt{cabal build} would report, and should also allow ghc-mod's +other features to work even in more complicated Cabal setups. + +Daniel Gr\"ober has been accepted for a summer internship at IIJ Innovation +Institute's Research Laboratory working on \texttt{ghc-mod} for two months +(August--September). He will be working on: +\begin{compactitem} + + \item adding GHCi-like interactive code execution, to bring \texttt{ghc-mod} up + to feature parity with GHCi and beyond, + + \item investigating how to best cooperate with \texttt{ide-backend}, + + \item adding a network interface to make using ghc-mod in other projects + easier, and + + \item if time allows, cleaning up the Emacs frontend to be more user-friendly + and in line with Emacs' conventions. +\end{compactitem} + +The goal of this work is to make \texttt{ghc-mod} the obvious choice for anyone +implementing Haskell support for a development environment and improving +\texttt{ghc-mod}'s overall feature set and reliability in order to give new as +well as experienced Haskell developers the best possible experience. + +Right now \texttt{ghc-mod} has only one core developer and only a handful of +occasional drive-by contributors. If \textit{you} want to help make Haskell +development even more fun come and join us! + +\FurtherReading + \url{https://github.com/kazu-yamamoto/ghc-mod} +\end{hcarentry} diff --git a/hcar-ghc-mod.tex b/hcar-ghc-mod.tex deleted file mode 100644 index ea738ca..0000000 --- a/hcar-ghc-mod.tex +++ /dev/null @@ -1,26 +0,0 @@ -% ghcmodHappyHaskellProgram-Kg.tex -\begin{hcarentry}[updated]{ghc-mod --- Happy Haskell Programming} -\report{Kazu Yamamoto}%11/14 -\status{open source, actively developed} -\makeheader - -For a long time, Kazu Yamamoto was the only active developer of ghc-mod, now two -new developers have joined: - -Alejandro Serrano merged the results of his Google Summer of Code project. He -implemented case splitting and sophisticated typed hole handling. Daniel Gröber -brushed up the internal code and introduced the GhcModT monad now used -throughout the exported API. As a result the API of \texttt{ghc-mod} drastically -changed with version 5.0.0. - -\texttt{ghc-modi} used to suffer from various consistency related issues -triggered by changes in the environment, for instance: changing file names of -modules, adding dependencies to the cabal file and installing new libraries. -\texttt{ghc-modi} v5.1.1 or later handles changes in the environment by -restarting the GHC session when this is detected. - -Kazu stepped down as release manager and Daniel took over. - -\FurtherReading - \url{http://www.mew.org/~kazu/proj/ghc-mod/en/} -\end{hcarentry} From 14c097530eb8701086482bf2bd9215a1b5569ed4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 1 Jun 2015 11:58:31 +0200 Subject: [PATCH 123/207] Fix stray tempdir --- Language/Haskell/GhcMod/Cradle.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index 7784631..c9438c4 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -57,12 +57,11 @@ customCradle wdir = do cabalFile <- MaybeT $ findCabalFile wdir let cabalDir = takeDirectory cabalFile cradleFile <- MaybeT $ findCradleFile cabalDir - tmpDir <- liftIO $ newTempDir cabalDir pkgDbStack <- liftIO $ parseCradle cradleFile return Cradle { cradleCurrentDir = wdir , cradleRootDir = cabalDir - , cradleTempDir = tmpDir + , cradleTempDir = error "tmpDir" , cradleCabalFile = Just cabalFile , cradlePkgDbStack = pkgDbStack } From 1e381a12a9532eb9d7f38051674d210af7ce1ab7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 4 Jun 2015 14:15:59 +0200 Subject: [PATCH 124/207] Remove some unnecessary dependencies from ghc-modi --- ghc-mod.cabal | 7 ------- 1 file changed, 7 deletions(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index e6be847..acdbef1 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -180,16 +180,9 @@ Executable ghc-modi Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 - , async - , containers , directory , filepath - , old-time , process - , split - , time - , ghc - , ghc-mod Test-Suite doctest Type: exitcode-stdio-1.0 From 49515b3eb8f9410313d7e69b11546210a90c1b65 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 5 Jun 2015 22:42:46 +0200 Subject: [PATCH 125/207] Fix #487, Modules from sandbox not visible --- Language/Haskell/GhcMod/CabalHelper.hs | 39 +++++++++++++++--------- Language/Haskell/GhcMod/Debug.hs | 7 ++++- Language/Haskell/GhcMod/PathsAndFiles.hs | 5 ++- Language/Haskell/GhcMod/Target.hs | 7 ++--- ghc-mod.cabal | 2 +- 5 files changed, 39 insertions(+), 21 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index a8a5ec7..c47f45e 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -17,7 +17,7 @@ {-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.CabalHelper ( getComponents - , getGhcPkgOptions + , getGhcMergedPkgOptions ) where import Control.Applicative @@ -38,9 +38,14 @@ import Paths_ghc_mod as GhcMod -- | Only package related GHC options, sufficient for things that don't need to -- access home modules -getGhcPkgOptions :: (Applicative m, MonadIO m, GmEnv m, GmLog m) - => m [(ChComponentName, [GHCOption])] -getGhcPkgOptions = map (\c -> (gmcName c, gmcGhcPkgOpts c)) `liftM` getComponents +getGhcMergedPkgOptions :: (Applicative m, MonadIO m, GmEnv m, GmLog m) + => m [GHCOption] +getGhcMergedPkgOptions = chCached Cached { + cacheFile = mergedPkgOptsCacheFile, + cachedAction = \ _ (progs, root, _) _ -> do + opts <- withCabal $ runQuery' progs root $ ghcMergedPkgOptions + return ([setupConfigPath], opts) + } helperProgs :: Options -> Programs helperProgs opts = Programs { @@ -56,16 +61,22 @@ helperProgs opts = Programs { -- 'resolveGmComponents'. getComponents :: (Applicative m, MonadIO m, GmEnv m, GmLog m) => m [GmComponent GMCRaw ChEntrypoint] -getComponents = do - opt <- options - Cradle {..} <- cradle - let gmVer = GhcMod.version - chVer = VERSION_cabal_helper - d = (helperProgs opt - , cradleRootDir "dist" - , (gmVer, chVer) - ) - withCabal $ cached cradleRootDir cabalHelperCache d +getComponents = chCached cabalHelperCache + +chCached c = do + root <- cradleRootDir <$> cradle + d <- cacheInputData root + withCabal $ cached root c d + where + cacheInputData root = do + opt <- options + return $ ( helperProgs opt + , root "dist" + , (gmVer, chVer) + ) + + gmVer = GhcMod.version + chVer = VERSION_cabal_helper cabalHelperCache :: (Functor m, Applicative m, MonadIO m) diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index e7d56de..fb5de2e 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -30,11 +30,16 @@ debugInfo = do Just _ -> cabalDebug Nothing -> return [] + pkgOpts <- packageGhcOptions + return $ unlines $ [ "Root directory: " ++ cradleRootDir , "Current directory: " ++ cradleCurrentDir + , "GHC Package flags:\n" ++ render (nest 4 $ + fsep $ map text pkgOpts) , "GHC System libraries: " ++ ghcLibDir - , "GHC user options: " ++ render (fsep $ map text ghcUserOptions) + , "GHC user options:\n" ++ render (nest 4 $ + fsep $ map text ghcUserOptions) ] ++ cabal cabalDebug :: IOish m => GhcModT m [String] diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 0dcc6f8..8c6c039 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -205,7 +205,10 @@ resolvedComponentsCacheFile :: String resolvedComponentsCacheFile = setupConfigPath <.> "ghc-mod.resolved-components" cabalHelperCacheFile :: String -cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-helper" +cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-components" + +mergedPkgOptsCacheFile :: String +mergedPkgOptsCacheFile = setupConfigPath <.> "ghc-mod.package-options" -- | @findCradleFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@. -- If it exists in the given directory it is returned otherwise @findCradleFile@ returns @Nothing@ diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 601707f..47066b8 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -73,8 +73,8 @@ withLightHscEnv opts action = gbracket initEnv teardownEnv action dflags' <- runLightGhc env $ do -- HomeModuleGraph and probably all other clients get into all sorts of -- trouble if the package state isn't initialized here - _ <- setSessionDynFlags =<< getSessionDynFlags - addCmdOpts opts =<< getSessionDynFlags + _ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags + getSessionDynFlags newHscEnv dflags' runLightGhc :: HscEnv -> LightGhc a -> IO a @@ -263,8 +263,7 @@ packageGhcOptions :: (Applicative m, MonadIO m, GmEnv m, GmLog m) => m [GHCOptio packageGhcOptions = do crdl <- cradle case cradleCabalFile crdl of - Just _ -> - (Set.toList . Set.fromList . concat . map snd) `liftM` getGhcPkgOptions + Just _ -> getGhcMergedPkgOptions Nothing -> sandboxOpts crdl sandboxOpts :: Monad m => Cradle -> m [String] diff --git a/ghc-mod.cabal b/ghc-mod.cabal index acdbef1..b9bda83 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -121,7 +121,7 @@ Library , bytestring , cereal >= 0.4 , containers - , cabal-helper >= 0.3.3.0 + , cabal-helper >= 0.3.5.0 , deepseq , directory , filepath From 27dba0e9aef5ae1b661870d0cec8aa17fdc9c33c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 7 Jun 2015 00:02:16 +0200 Subject: [PATCH 126/207] Update bump.sh --- scripts/bump.sh | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/scripts/bump.sh b/scripts/bump.sh index 445622e..986b46b 100755 --- a/scripts/bump.sh +++ b/scripts/bump.sh @@ -1,5 +1,7 @@ #!/bin/sh +set -e + if [ -z "$1" ]; then echo "Usage: $0 VERSION" >&2 exit 1 @@ -19,6 +21,13 @@ sed -i 's/(defconst ghc-version ".*")/(defconst ghc-version "'"$VERSION"'")/' \ sed -r -i 's/^(Version:[[:space:]]*)[0-9.]+/\1'"$VERSION"'/' ghc-mod.cabal +git add elisp/ghc.el ghc-mod.cabal +git commit -m "Bump version to $VERSION" + +git checkout release +#git merge master +git merge -s recursive -X theirs master + ( tac ChangeLog; echo "\n$(date '+%Y-%m-%d') v$VERSION" ) | tac \ > ChangeLog.tmp @@ -26,6 +35,8 @@ mv ChangeLog.tmp ChangeLog emacs -q -nw ChangeLog -git add ChangeLog elisp/ghc.el ghc-mod.cabal -git commit -m "Bump version to $VERSION" +git add ChangeLog +git commit -m "ChangeLog" + + git tag "v$VERSION" From baf557d5bf372e8a3f088d9758008996d905ee6d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 7 Jun 2015 01:53:41 +0200 Subject: [PATCH 127/207] Comment --- Language/Haskell/GhcMod/Target.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 47066b8..0299ff9 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -321,7 +321,9 @@ resolveModule env srcDirs (Left fn') = liftIO $ do fn <- canonicalizePath fn'' emn <- fileModuleName env fn return $ case emn of - Left _ -> Nothing + Left _ -> Nothing -- TODO: should expose these errors otherwise + -- modules with preprocessor/parse errors are + -- going to be missing Right mmn -> Just $ case mmn of Nothing -> mkMainModulePath fn From bed42f10fe0cd40f5355c53a4204766ba2ef7d7d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 7 Jun 2015 02:44:11 +0200 Subject: [PATCH 128/207] Refactor L.H.G.Caching --- Language/Haskell/GhcMod/Caching.hs | 68 +++++++++++++++++++++--------- 1 file changed, 47 insertions(+), 21 deletions(-) diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs index 71067f9..41e24b6 100644 --- a/Language/Haskell/GhcMod/Caching.hs +++ b/Language/Haskell/GhcMod/Caching.hs @@ -10,19 +10,47 @@ import Utils (TimedFile(..), timeMaybe, mightExist) import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Logging -data Cached m d a = - Cached { cacheFile :: FilePath, - cachedAction :: TimedCacheFiles -> d -> Maybe a -> m ([FilePath], a) - -- ^ The cached action, will only run if - -- * The cache doesn\'t exist yet - -- * The cache exists and 'inputData' changed - -- * any files in 'inputFiles' are older than 'cacheFile'. - } +data Cached m d a = Cached { + cacheFile :: FilePath, -data TimedCacheFiles = - TimedCacheFiles { tcCacheFile :: Maybe TimedFile, - tcFiles :: [TimedFile] - } + + cachedAction :: TimedCacheFiles + -> d + -> Maybe a + -> m ([FilePath], a) + + -- ^ @cachedAction tcf data ma@ + -- + -- * @tcf@: Input file timestamps. Not technically necessary, just an + -- optimizazion when knowing which input files changed can make updating the + -- cache faster + -- + -- * @data@: Arbitrary static input data can be used to invalidate the cache + -- using something other than file timestamps i.e. environment tool version + -- numbers + -- + -- * @ma@: Cached data if it existed + -- + -- Returns: + -- + -- * @fst@: Input files used in generating the cache + -- + -- * @snd@: Cache data, will be stored alongside the static input data in the + -- 'cacheFile' + -- + -- The cached action, will only run if one of the following is true: + -- + -- * 'cacheFile' doesn\'t exist yet + -- * 'cacheFile' exists and 'inputData' changed + -- * any files returned by the cached action changed + } + +data TimedCacheFiles = TimedCacheFiles { + tcCacheFile :: Maybe TimedFile, + -- ^ 'cacheFile' timestamp + tcFiles :: [TimedFile] + -- ^ Timestamped files returned by the cached action + } -- | Cache a MonadIO action with proper invalidation. cached :: forall m a d. (MonadIO m, GmLog m, Serialize a, Eq d, Serialize d) @@ -33,20 +61,18 @@ cached :: forall m a d. (MonadIO m, GmLog m, Serialize a, Eq d, Serialize d) cached dir cd d = do mcc <- readCache tcfile <- liftIO $ timeMaybe (cacheFile cd) - let defTcf = TimedCacheFiles tcfile [] - case mcc of - Nothing -> writeCache defTcf Nothing "cache missing" + Nothing -> + writeCache (TimedCacheFiles tcfile []) Nothing "cache missing" Just (ifs, d', a) | d /= d' -> do tcf <- timeCacheInput dir (cacheFile cd) ifs writeCache tcf (Just a) "input data changed" Just (ifs, _, a) -> do - tcf <- timeCacheInput dir (cacheFile cd) ifs - let invifs = invalidatingInputFiles tcf - case invifs of - Nothing -> writeCache tcf (Just a) "cache missing, existed a sec ago WTF?" - Just [] -> return a - Just _ -> writeCache tcf (Just a) "input files changed" + tcf <- timeCacheInput dir (cacheFile cd) ifs + case invalidatingInputFiles tcf of + Just [] -> return a + Just _ -> writeCache tcf (Just a) "input files changed" + Nothing -> writeCache tcf (Just a) "cache missing, existed a sec ago WTF?" where writeCache tcf ma cause = do From acfc575e13ee1427531072285cb9b140ef3ac47c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 7 Jun 2015 02:45:50 +0200 Subject: [PATCH 129/207] Make unknown component fallback message more clear --- Language/Haskell/GhcMod/Target.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 0299ff9..e8c35bf 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -183,7 +183,7 @@ targetGhcOptions crdl sefnmn = do if noCandidates && noModuleHasAnyAssignment then do - gmLog GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to sandbox only project options." + gmLog GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to guessed GHC options." sandboxOpts crdl else do when noCandidates $ From 21087650d9741fae231d0d1f9e02037a1c3504af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 7 Jun 2015 03:36:50 +0200 Subject: [PATCH 130/207] Fix travis --- Language/Haskell/GhcMod/CabalHelper.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index c47f45e..53b6007 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -24,6 +24,7 @@ import Control.Applicative import Control.Monad import Data.Monoid import Data.Version +import Data.Serialize (Serialize) import Distribution.Helper import qualified Language.Haskell.GhcMod.Types as T import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram, @@ -63,6 +64,8 @@ getComponents :: (Applicative m, MonadIO m, GmEnv m, GmLog m) => m [GmComponent GMCRaw ChEntrypoint] getComponents = chCached cabalHelperCache +chCached :: (Applicative m, MonadIO m, GmEnv m, GmLog m, Serialize a) + => Cached m (Programs, FilePath, (Version, [Char])) a -> m a chCached c = do root <- cradleRootDir <$> cradle d <- cacheInputData root From bfa0b965ee3497f5f41d261072dc6bae0af00a06 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 10 Jun 2015 11:00:56 +0200 Subject: [PATCH 131/207] Fix impredicativity related issue See: https://ghc.haskell.org/trac/ghc/ticket/10443 --- Language/Haskell/GhcMod/Monad/Types.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index f769a5b..b2ec57b 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -342,8 +342,9 @@ instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where (ErrorT GhcModError (JournalT GhcModLog (ReaderT GhcModEnv m) ) ) ) a - liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> - f $ runInBase . unGhcModT + + liftBaseWith f = GhcModT (liftBaseWith $ \runInBase -> + f $ runInBase . unGhcModT) restoreM = GhcModT . restoreM {-# INLINE liftBaseWith #-} From 509f43999fc303f27c0bd6569c502360647084b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 6 Jul 2015 18:41:34 +0200 Subject: [PATCH 132/207] cabal-helper-0.3.5.0 is broken... --- ghc-mod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index b9bda83..0b670b8 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -121,7 +121,7 @@ Library , bytestring , cereal >= 0.4 , containers - , cabal-helper >= 0.3.5.0 + , cabal-helper >= 0.3.6.0 , deepseq , directory , filepath From 3bf4243bafc2c5713da6c63851e1a2d0a206d768 Mon Sep 17 00:00:00 2001 From: Anthony Cowley Date: Thu, 2 Jul 2015 21:47:17 -0400 Subject: [PATCH 133/207] Serialize check-syntax - Wait for ghc-mod to be ready before trying to check a buffer - Times out after 10s with an error - Only check-syntax visible buffers - check-syntax when switching to a buffer --- elisp/ghc-check.el | 11 ++++++++--- elisp/ghc.el | 3 +++ 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el index f90fded..4e7236a 100644 --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -64,9 +64,14 @@ nil does not display errors/warnings. (defun ghc-check-syntax () (interactive) - (ghc-with-process (ghc-check-send) - 'ghc-check-callback - (lambda () (setq mode-line-process " -:-")))) + ;; Only check syntax of visible buffers + (when (get-buffer-window (current-buffer) t) + (with-timeout + (10 (error "ghc process may have hung or exited with an error")) + (while ghc-process-running (sleep-for 0.1))) + (ghc-with-process (ghc-check-send) + 'ghc-check-callback + (lambda () (setq mode-line-process " -:-"))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc.el b/elisp/ghc.el index c15d536..199d11a 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -117,6 +117,9 @@ (setq ghc-initialized t) (defadvice save-buffer (after ghc-check-syntax-on-save activate) "Check syntax with GHC when a haskell-mode buffer is saved." + (when (eq 'haskell-mode major-mode) (ghc-check-syntax))) + (defadvice switch-to-buffer (after ghc-check-syntax-on-switch-to-buffer activate) + "Check syntax with GHC when switching to a haskell-mode buffer." (when (eq 'haskell-mode major-mode) (ghc-check-syntax)))) (ghc-import-module) (ghc-check-syntax)) From e06e4d25df19f2def5eb11c0460e6294ace66bf1 Mon Sep 17 00:00:00 2001 From: Anthony Cowley Date: Thu, 2 Jul 2015 21:50:08 -0400 Subject: [PATCH 134/207] More sensitive to cache invalidation. This addresses a problem where changes to a .cabal file were not invalidating the cache files. --- Language/Haskell/GhcMod/Target.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index e8c35bf..9fa2af1 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -199,8 +199,9 @@ resolvedComponentsCache = Cached { cacheFile = resolvedComponentsCacheFile, cachedAction = \tcfs comps ma -> do Cradle {..} <- cradle - let mums = - case invalidatingInputFiles tcfs of + let iifsM = invalidatingInputFiles tcfs + mums = + case iifsM of Nothing -> Nothing Just iifs -> let @@ -210,10 +211,12 @@ resolvedComponentsCache = Cached { in if null changedFiles then Nothing else Just $ map Left changedFiles - - case ma of - Just mcs -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs } - Nothing -> return () + setupChanged = maybe False + (elem $ cradleRootDir setupConfigPath) + iifsM + case (setupChanged, ma) of + (False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs } + _ -> return () -- liftIO $ print ("changed files", mums :: Maybe [Either FilePath ()]) From 42e72b3816ad40a2304b6bab3df4ef712909030d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 19 Jun 2015 17:15:14 +0200 Subject: [PATCH 135/207] Fix fileModuleName not working on CPP modules given by path --- Language/Haskell/GhcMod/HomeModuleGraph.hs | 34 +++++++---- Language/Haskell/GhcMod/Logger.hs | 8 +++ Language/Haskell/GhcMod/Target.hs | 71 +++++++++++++--------- test/TargetSpec.hs | 12 ++++ 4 files changed, 83 insertions(+), 42 deletions(-) diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index 7aafc16..3b382a0 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -214,9 +214,7 @@ updateHomeModuleGraph' env smp0 = do preprocess' :: m (Maybe (DynFlags, FilePath)) preprocess' = do let fn = mpPath mp - ep <- liftIO $ withLogger' env $ \setDf -> let - env' = env { hsc_dflags = setDf (hsc_dflags env) } - in preprocess env' (fn, Nothing) + ep <- preprocessFile env fn case ep of Right (_, x) -> return $ Just x Left errs -> do @@ -240,13 +238,25 @@ updateHomeModuleGraph' env smp0 = do $ map unLoc hsmodImports liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns -fileModuleName :: HscEnv - -> FilePath - -> IO (Either ErrorMessages (Maybe ModuleName)) +preprocessFile :: MonadIO m => + HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath))) +preprocessFile env file = + liftIO $ withLogger' env $ \setDf -> do + let env' = env { hsc_dflags = setDf (hsc_dflags env) } + preprocess env' (file, Nothing) + +fileModuleName :: + HscEnv -> FilePath -> IO (Either [String] (Maybe ModuleName)) fileModuleName env fn = handle (\(_ :: SomeException) -> return $ Right Nothing) $ do - src <- readFile fn - case parseModuleHeader src (hsc_dflags env) fn of - Left errs -> return (Left errs) - Right (_, lmdl) -> do - let HsModule {..} = unLoc lmdl - return $ Right $ unLoc <$> hsmodName + ep <- preprocessFile env fn + case ep of + Left errs -> do + return $ Left errs + Right (_warns, (dflags, procdFile)) -> do + src <- readFile procdFile + case parseModuleHeader src dflags procdFile of + Left errs -> do + return $ Left $ errBagToStrList env errs + Right (_, lmdl) -> do + let HsModule {..} = unLoc lmdl + return $ Right $ unLoc <$> hsmodName diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 8778d33..2d97580 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -3,6 +3,7 @@ module Language.Haskell.GhcMod.Logger ( , withLogger' , checkErrorPrefix , errsToStr + , errBagToStrList ) where import Control.Arrow @@ -93,6 +94,13 @@ withLogger' env action = do GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex] ] +errBagToStrList :: HscEnv -> Bag ErrMsg -> [String] +errBagToStrList env errs = let + dflags = hsc_dflags env + pu = icPrintUnqual dflags (hsc_IC env) + st = mkUserStyle pu AllTheWay + in errsToStr dflags st $ bagToList errs + ---------------------------------------------------------------- -- | Converting 'SourceError' to 'String'. diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index e8c35bf..a952840 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -27,6 +27,7 @@ import SysTools import DynFlags import HscMain import HscTypes +import Bag (bagToList) import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Monad.Types @@ -36,9 +37,11 @@ import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logging +import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils + import Data.Maybe import Data.Monoid import Data.Either @@ -274,7 +277,7 @@ sandboxOpts crdl = (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl) resolveGmComponent :: (IOish m, GmLog m, GmEnv m) - => Maybe [Either FilePath ModuleName] -- ^ Updated modules + => Maybe [CompilationUnit] -- ^ Updated modules -> GmComponent GMCRaw (Set ModulePath) -> m (GmComponent GMCResolved (Set ModulePath)) resolveGmComponent mums c@GmComponent {..} = do @@ -298,42 +301,18 @@ resolveGmComponent mums c@GmComponent {..} = do [ "-optP-include", "-optP" ++ macrosHeaderPath ] ] -resolveEntrypoint :: IOish m +resolveEntrypoint :: (IOish m, GmLog m) => Cradle -> GmComponent GMCRaw ChEntrypoint -> m (GmComponent GMCRaw (Set ModulePath)) -resolveEntrypoint Cradle {..} c@GmComponent {..} = +resolveEntrypoint Cradle {..} c@GmComponent {..} = do withLightHscEnv gmcGhcSrcOpts $ \env -> do let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints rms <- resolveModule env srcDirs `mapM` eps return c { gmcEntrypoints = Set.fromList $ catMaybes rms } -resolveModule :: MonadIO m => - HscEnv -> [FilePath] -> Either FilePath ModuleName -> m (Maybe ModulePath) -resolveModule env _srcDirs (Right mn) = - liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn -resolveModule env srcDirs (Left fn') = liftIO $ do - mfn <- findFile' srcDirs fn' - case mfn of - Nothing -> return Nothing - Just fn'' -> do - fn <- canonicalizePath fn'' - emn <- fileModuleName env fn - return $ case emn of - Left _ -> Nothing -- TODO: should expose these errors otherwise - -- modules with preprocessor/parse errors are - -- going to be missing - Right mmn -> Just $ - case mmn of - Nothing -> mkMainModulePath fn - Just mn -> ModulePath mn fn - where - findFile' dirs file = - getFirst . mconcat <$> mapM (fmap First . mightExist . (file)) dirs - -resolveChEntrypoints :: - FilePath -> ChEntrypoint -> IO [Either FilePath ModuleName] +resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit] resolveChEntrypoints _ (ChLibEntrypoint em om) = return $ map (Right . chModToMod) (em ++ om) @@ -351,8 +330,40 @@ resolveChEntrypoints srcDir ChSetupEntrypoint = do chModToMod :: ChModuleName -> ModuleName chModToMod (ChModuleName mn) = mkModuleName mn -resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m) => - Maybe [Either FilePath ModuleName] +resolveModule :: (MonadIO m, GmLog m) => + HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath) +resolveModule env _srcDirs (Right mn) = + liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn +resolveModule env srcDirs (Left fn') = do + mfn <- liftIO $ findFile' srcDirs fn' + case mfn of + Nothing -> return Nothing + Just fn'' -> do + fn <- liftIO $ canonicalizePath fn'' + emn <- liftIO $ fileModuleName env fn + case emn of + Left errs -> do + gmLog GmWarning ("resolveModule " ++ show fn) $ + empty $+$ (vcat $ map text errs) + return Nothing -- TODO: should expose these errors otherwise + -- modules with preprocessor/parse errors are + -- going to be missing + Right mmn -> return $ Just $ + case mmn of + Nothing -> mkMainModulePath fn + Just mn -> ModulePath mn fn + where + -- needed for ghc 7.4 + findFile' dirs file = + getFirst . mconcat <$> mapM (fmap First . mightExist . (file)) dirs + + -- fileModuleName fn (dir:dirs) + -- | makeRelative dir fn /= fn + +type CompilationUnit = Either FilePath ModuleName + +resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m) + => Maybe [CompilationUnit] -- ^ Updated modules -> [GmComponent GMCRaw (Set ModulePath)] -> m (Map ChComponentName (GmComponent GMCResolved (Set ModulePath))) diff --git a/test/TargetSpec.hs b/test/TargetSpec.hs index 8429621..e75807c 100644 --- a/test/TargetSpec.hs +++ b/test/TargetSpec.hs @@ -10,6 +10,8 @@ import TestUtils import GHC import Data.List import Data.Maybe +import System.Directory +import System.FilePath spec :: Spec spec = do @@ -33,3 +35,13 @@ spec = do mdl <- findModule "Data.List" Nothing mmi <- getModuleInfo mdl liftIO $ isJust mmi `shouldBe` True + + + describe "resolveModule" $ do + it "Works when a module given as path uses CPP" $ do + dir <- getCurrentDirectory + print dir + let srcDirs = [dir "test/data/target/src"] + withLightHscEnv [] $ \env -> runNullLog $ do + Just _ <- resolveModule env srcDirs (Left $ dir "test/data/target/src/A/B/C/D/E.hs") + return () From 160cec86bb6a0ecf9486428fed5f7e682c5bba38 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 19 Jun 2015 17:21:17 +0200 Subject: [PATCH 136/207] Comment --- Language/Haskell/GhcMod/Target.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index a952840..eb3cac9 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -312,6 +312,9 @@ resolveEntrypoint Cradle {..} c@GmComponent {..} = do rms <- resolveModule env srcDirs `mapM` eps return c { gmcEntrypoints = Set.fromList $ catMaybes rms } +-- TODO: remember that he file from `main-is:` is always module `Main` and let +-- ghc do the warning about it. Right now we run that module through +-- resolveModule like any other resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit] resolveChEntrypoints _ (ChLibEntrypoint em om) = return $ map (Right . chModToMod) (em ++ om) From f023d939e2edfc7e6874be76b5ad8f5de51e4124 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 3 Aug 2015 03:09:56 +0200 Subject: [PATCH 137/207] Fix GHC 7.10 warnings --- Language/Haskell/GhcMod/Boot.hs | 1 + Language/Haskell/GhcMod/Browse.hs | 3 ++- Language/Haskell/GhcMod/CabalHelper.hs | 5 ++-- Language/Haskell/GhcMod/Check.hs | 3 ++- Language/Haskell/GhcMod/Convert.hs | 3 ++- Language/Haskell/GhcMod/Cradle.hs | 1 + Language/Haskell/GhcMod/DynFlags.hs | 3 ++- Language/Haskell/GhcMod/Find.hs | 3 ++- Language/Haskell/GhcMod/Gap.hs | 3 ++- Language/Haskell/GhcMod/GhcPkg.hs | 3 ++- Language/Haskell/GhcMod/HomeModuleGraph.hs | 7 +++--- Language/Haskell/GhcMod/Info.hs | 1 + Language/Haskell/GhcMod/Logger.hs | 3 ++- Language/Haskell/GhcMod/Logging.hs | 1 + Language/Haskell/GhcMod/Monad.hs | 1 + Language/Haskell/GhcMod/Monad/Types.hs | 9 ++++---- Language/Haskell/GhcMod/PathsAndFiles.hs | 3 ++- Language/Haskell/GhcMod/PkgDoc.hs | 3 ++- Language/Haskell/GhcMod/SrcUtils.hs | 3 ++- Language/Haskell/GhcMod/Target.hs | 27 +++++++++++----------- Language/Haskell/GhcMod/Types.hs | 1 + Language/Haskell/GhcMod/Utils.hs | 1 + Language/Haskell/GhcMod/World.hs | 5 ++-- Utils.hs | 2 ++ src/GHCMod.hs | 1 + src/Misc.hs | 3 ++- 26 files changed, 62 insertions(+), 37 deletions(-) diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs index 70c77b6..c0abae5 100644 --- a/Language/Haskell/GhcMod/Boot.hs +++ b/Language/Haskell/GhcMod/Boot.hs @@ -1,6 +1,7 @@ module Language.Haskell.GhcMod.Boot where import Control.Applicative +import Prelude import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.Flag import Language.Haskell.GhcMod.Lang diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 19a4b02..6093c9e 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -2,7 +2,7 @@ module Language.Haskell.GhcMod.Browse ( browse ) where -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Exception (SomeException(..)) import Data.Char import Data.List @@ -20,6 +20,7 @@ import Outputable import TyCon (isAlgTyCon) import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) import Exception (ExceptionMonad, ghandle) +import Prelude ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 53b6007..735a62e 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -34,6 +34,7 @@ import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World import Language.Haskell.GhcMod.PathsAndFiles import System.FilePath +import Prelude import Paths_ghc_mod as GhcMod @@ -61,7 +62,7 @@ helperProgs opts = Programs { -- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by -- 'resolveGmComponents'. getComponents :: (Applicative m, MonadIO m, GmEnv m, GmLog m) - => m [GmComponent GMCRaw ChEntrypoint] + => m [GmComponent 'GMCRaw ChEntrypoint] getComponents = chCached cabalHelperCache chCached :: (Applicative m, MonadIO m, GmEnv m, GmLog m, Serialize a) @@ -83,7 +84,7 @@ chCached c = do cabalHelperCache :: (Functor m, Applicative m, MonadIO m) - => Cached m (Programs, FilePath, (Version, String)) [GmComponent GMCRaw ChEntrypoint] + => Cached m (Programs, FilePath, (Version, String)) [GmComponent 'GMCRaw ChEntrypoint] cabalHelperCache = Cached { cacheFile = cabalHelperCacheFile, cachedAction = \ _ (progs, root, _) _ -> diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index 5820bf0..f4bd658 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -5,7 +5,8 @@ module Language.Haskell.GhcMod.Check ( , expand ) where -import Control.Applicative ((<$>)) +import Control.Applicative +import Prelude import Language.Haskell.GhcMod.DynFlags import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Logger diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index a679aa0..2715696 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -5,7 +5,8 @@ module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFoun import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types -import Control.Applicative ((<$>)) +import Control.Applicative +import Prelude type Builder = String -> String diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index c9438c4..d409ce7 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -16,6 +16,7 @@ import Control.Monad.Trans.Maybe import Data.Maybe import System.Directory import System.FilePath +import Prelude ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs index 2c8ee53..f1950f7 100644 --- a/Language/Haskell/GhcMod/DynFlags.hs +++ b/Language/Haskell/GhcMod/DynFlags.hs @@ -2,7 +2,7 @@ module Language.Haskell.GhcMod.DynFlags where -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Monad (void) import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..)) import qualified GHC as G @@ -11,6 +11,7 @@ import GhcMonad import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types import System.IO.Unsafe (unsafePerformIO) +import Prelude setEmptyLogger :: DynFlags -> DynFlags setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return () diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index aee450c..11228f5 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -14,7 +14,7 @@ module Language.Haskell.GhcMod.Find #endif where -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Monad (when, void, (<=<)) import Data.Function (on) import Data.List (groupBy, sort) @@ -31,6 +31,7 @@ import Module (moduleName) import System.Directory (doesFileExist, getModificationTime) import System.FilePath (()) import System.IO +import Prelude import Data.Map (Map) import qualified Data.Map as M diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 4719185..9ca8cd9 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -49,7 +49,7 @@ import CoreSyn (CoreExpr) import Data.List (intersperse) import Data.Maybe (catMaybes) import Data.Time.Clock (UTCTime) -import Data.Traversable (traverse) +import Data.Traversable import DataCon (dataConRepType) import Desugar (deSugarExpr) import DynFlags @@ -104,6 +104,7 @@ import SrcLoc import Packages import Language.Haskell.GhcMod.Types (Expression(..)) +import Prelude ---------------------------------------------------------------- ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index 7eaa2ed..3114916 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -8,13 +8,14 @@ module Language.Haskell.GhcMod.GhcPkg ( ) where import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) -import Control.Applicative ((<$>)) +import Control.Applicative import Data.List.Split (splitOn) import Data.Maybe import Exception (handleIO) import Language.Haskell.GhcMod.Types import System.Directory (doesDirectoryExist, getAppUserDataDirectory) import System.FilePath (()) +import Prelude ghcVersion :: Int ghcVersion = read cProjectVersionInt diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index 3b382a0..d10f483 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -41,19 +41,20 @@ import GHC import HscTypes import Control.Arrow ((&&&)) -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.State.Strict (execStateT) import Control.Monad.State.Class import Data.Maybe -import Data.Monoid +import Data.Monoid as Monoid import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import System.FilePath import System.Directory +import Prelude import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Logger @@ -220,7 +221,7 @@ updateHomeModuleGraph' env smp0 = do Left errs -> do -- TODO: Remember these and present them as proper errors if this is -- the file the user is looking at. - gmLog GmWarning ("preprocess " ++ show fn) $ empty $+$ (vcat $ map text errs) + gmLog GmWarning ("preprocess " ++ show fn) $ Monoid.mempty $+$ (vcat $ map text errs) return Nothing imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath) diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 6344a5d..be32635 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -10,6 +10,7 @@ import Data.Maybe (catMaybes) import System.FilePath import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) +import Prelude import qualified GHC as G import qualified Language.Haskell.GhcMod.Gap as Gap diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 2d97580..3fbd436 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -7,7 +7,7 @@ module Language.Haskell.GhcMod.Logger ( ) where import Control.Arrow -import Control.Applicative ((<$>)) +import Control.Applicative import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) @@ -27,6 +27,7 @@ import Language.Haskell.GhcMod.DynFlags (withDynFlags) import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Error import qualified Language.Haskell.GhcMod.Gap as Gap +import Prelude type Builder = [String] -> [String] diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 019c12b..b6052c2 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -32,6 +32,7 @@ import Data.Char import Data.Monoid (mempty, mappend, mconcat, (<>)) import System.IO import Text.PrettyPrint hiding (style, (<>)) +import Prelude import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Pretty diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 8f89f1c..0d74b5d 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -46,6 +46,7 @@ import Control.Monad.Trans.Journal (runJournalT) import Exception (ExceptionMonad(..)) import System.Directory +import Prelude withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a withCradle cradledir f = diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index b2ec57b..88519b3 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -71,7 +71,7 @@ import DynFlags import Exception import HscTypes -import Control.Applicative (Applicative, Alternative, (<$>)) +import Control.Applicative import Control.Monad import Control.Monad.Reader (ReaderT(..)) @@ -96,12 +96,13 @@ import Data.Monoid (Monoid) #endif import Data.Set (Set) -import Data.Map (Map, empty) +import Data.Map as Map (Map, empty) import Data.Maybe import Data.Monoid import Data.IORef import Distribution.Helper import Text.PrettyPrint (Doc) +import Prelude import qualified MonadUtils as GHC (MonadIO(..)) @@ -127,12 +128,12 @@ data GmGhcSession = GmGhcSession { data GhcModState = GhcModState { gmGhcSession :: !(Maybe GmGhcSession) - , gmComponents :: !(Map ChComponentName (GmComponent GMCResolved (Set ModulePath))) + , gmComponents :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) , gmCompilerMode :: !CompilerMode } defaultGhcModState :: GhcModState -defaultGhcModState = GhcModState Nothing empty Simple +defaultGhcModState = GhcModState Nothing Map.empty Simple data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read) diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 8c6c039..ebb5c4b 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -25,7 +25,7 @@ import Control.Monad import Data.List import Data.Char import Data.Maybe -import Data.Traversable (traverse) +import Data.Traversable import Distribution.Helper (buildPlatform) import System.Directory import System.FilePath @@ -36,6 +36,7 @@ import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Caching import qualified Language.Haskell.GhcMod.Utils as U import Utils (mightExist) +import Prelude -- | Guaranteed to be a path to a directory with no trailing slash. type DirPath = FilePath diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs index 8497fcc..a83141f 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ b/Language/Haskell/GhcMod/PkgDoc.hs @@ -5,7 +5,8 @@ import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Utils -import Control.Applicative ((<$>)) +import Control.Applicative +import Prelude -- | Obtaining the package name and the doc path of a module. pkgDoc :: IOish m => String -> GhcModT m String diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index de398dd..0938f81 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -3,7 +3,7 @@ module Language.Haskell.GhcMod.SrcUtils where -import Control.Applicative ((<$>)) +import Control.Applicative import CoreUtils (exprType) import Data.Generics import Data.Maybe (fromMaybe) @@ -19,6 +19,7 @@ import qualified Language.Haskell.GhcMod.Gap as Gap import OccName (OccName) import Outputable (PprStyle) import TcHsSyn (hsPatType) +import Prelude ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index eb3cac9..24e62e4 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -18,7 +18,7 @@ module Language.Haskell.GhcMod.Target where import Control.Arrow -import Control.Applicative (Applicative, (<$>)) +import Control.Applicative import Control.Monad.Reader (runReaderT) import GHC import GHC.Paths (libdir) @@ -27,7 +27,6 @@ import SysTools import DynFlags import HscMain import HscTypes -import Bag (bagToList) import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Monad.Types @@ -37,22 +36,22 @@ import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Data.Maybe -import Data.Monoid +import Data.Monoid as Monoid import Data.Either import Data.Foldable (foldrM) -import Data.Traversable (traverse) +import Data.Traversable import Data.IORef import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Distribution.Helper +import Prelude import System.Directory import System.FilePath @@ -196,8 +195,8 @@ targetGhcOptions crdl sefnmn = do return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs resolvedComponentsCache :: IOish m => Cached (GhcModT m) - [GmComponent GMCRaw (Set.Set ModulePath)] - (Map.Map ChComponentName (GmComponent GMCResolved (Set.Set ModulePath))) + [GmComponent 'GMCRaw (Set.Set ModulePath)] + (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) resolvedComponentsCache = Cached { cacheFile = resolvedComponentsCacheFile, cachedAction = \tcfs comps ma -> do @@ -278,8 +277,8 @@ sandboxOpts crdl = resolveGmComponent :: (IOish m, GmLog m, GmEnv m) => Maybe [CompilationUnit] -- ^ Updated modules - -> GmComponent GMCRaw (Set ModulePath) - -> m (GmComponent GMCResolved (Set ModulePath)) + -> GmComponent 'GMCRaw (Set ModulePath) + -> m (GmComponent 'GMCResolved (Set ModulePath)) resolveGmComponent mums c@GmComponent {..} = do withLightHscEnv ghcOpts $ \env -> do let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs @@ -303,8 +302,8 @@ resolveGmComponent mums c@GmComponent {..} = do resolveEntrypoint :: (IOish m, GmLog m) => Cradle - -> GmComponent GMCRaw ChEntrypoint - -> m (GmComponent GMCRaw (Set ModulePath)) + -> GmComponent 'GMCRaw ChEntrypoint + -> m (GmComponent 'GMCRaw (Set ModulePath)) resolveEntrypoint Cradle {..} c@GmComponent {..} = do withLightHscEnv gmcGhcSrcOpts $ \env -> do let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs @@ -347,7 +346,7 @@ resolveModule env srcDirs (Left fn') = do case emn of Left errs -> do gmLog GmWarning ("resolveModule " ++ show fn) $ - empty $+$ (vcat $ map text errs) + Monoid.mempty $+$ (vcat $ map text errs) return Nothing -- TODO: should expose these errors otherwise -- modules with preprocessor/parse errors are -- going to be missing @@ -368,8 +367,8 @@ type CompilationUnit = Either FilePath ModuleName resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m) => Maybe [CompilationUnit] -- ^ Updated modules - -> [GmComponent GMCRaw (Set ModulePath)] - -> m (Map ChComponentName (GmComponent GMCResolved (Set ModulePath))) + -> [GmComponent 'GMCRaw (Set ModulePath)] + -> m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) resolveGmComponents mumns cs = do s <- gmsGet m' <- foldrM' (gmComponents s) cs $ \c m -> do diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index b33c01a..416c04c 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -31,6 +31,7 @@ import qualified MonadUtils as GHC (MonadIO(..)) import GHC (ModuleName, moduleNameString, mkModuleName) import PackageConfig (PackageConfig) import GHC.Generics +import Prelude -- | A constraint alias (-XConstraintKinds) to make functions dealing with -- 'GhcModT' somewhat cleaner. diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index a9a092b..e397ad0 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -39,6 +39,7 @@ import Text.Printf import Paths_ghc_mod (getLibexecDir) import Utils +import Prelude -- dropWhileEnd is not provided prior to base 4.5.0.0. dropWhileEnd :: (a -> Bool) -> [a] -> [a] diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs index 41035f3..9f77a0c 100644 --- a/Language/Haskell/GhcMod/World.hs +++ b/Language/Haskell/GhcMod/World.hs @@ -5,12 +5,13 @@ import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils -import Control.Applicative ((<$>)) +import Control.Applicative import Data.Maybe -import Data.Traversable (traverse) +import Data.Traversable import System.FilePath (()) import GHC.Paths (libdir) +import Prelude data World = World { worldPackageCaches :: [TimedFile] diff --git a/Utils.hs b/Utils.hs index 7bfd18e..a4c1ff2 100644 --- a/Utils.hs +++ b/Utils.hs @@ -10,6 +10,8 @@ import Data.Time (UTCTime) #else import System.Time (ClockTime) #endif +import Prelude + #if MIN_VERSION_directory(1,2,0) type ModTime = UTCTime diff --git a/src/GHCMod.hs b/src/GHCMod.hs index ba9b79d..50be2b1 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -23,6 +23,7 @@ import System.Exit (exitFailure) import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush) import System.Exit (exitSuccess) import Text.PrettyPrint +import Prelude import Misc diff --git a/src/Misc.hs b/src/Misc.hs index 2c646c6..6b6fbcf 100644 --- a/src/Misc.hs +++ b/src/Misc.hs @@ -13,12 +13,13 @@ module Misc ( , checkDb ) where -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Concurrent.Async (Async, async, wait) import Control.Exception (Exception) import CoreMonad (liftIO) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Typeable (Typeable) +import Prelude import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal From ec008fbd1e8a39300ed39b3db8c8f161a2dc2095 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 3 Aug 2015 04:45:58 +0200 Subject: [PATCH 138/207] Bump cabal-helper dependency --- ghc-mod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 0b670b8..d34566c 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -121,7 +121,7 @@ Library , bytestring , cereal >= 0.4 , containers - , cabal-helper >= 0.3.6.0 + , cabal-helper >= 0.3.7.0 , deepseq , directory , filepath From 75d4a2a9d661c901c3cf6e274cdccf422fc75a10 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 3 Aug 2015 05:20:14 +0200 Subject: [PATCH 139/207] Some debug logging for `cabal configure` etc. --- Language/Haskell/GhcMod/CabalHelper.hs | 21 ++++++++++++--------- Language/Haskell/GhcMod/Target.hs | 2 +- Language/Haskell/GhcMod/Utils.hs | 2 +- 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 735a62e..2f51ebb 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -33,6 +33,7 @@ import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.Logging import System.FilePath import Prelude @@ -40,11 +41,11 @@ import Paths_ghc_mod as GhcMod -- | Only package related GHC options, sufficient for things that don't need to -- access home modules -getGhcMergedPkgOptions :: (Applicative m, MonadIO m, GmEnv m, GmLog m) +getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmLog m) => m [GHCOption] getGhcMergedPkgOptions = chCached Cached { cacheFile = mergedPkgOptsCacheFile, - cachedAction = \ _ (progs, root, _) _ -> do + cachedAction = \ _tcf (progs, root, _) _ma -> do opts <- withCabal $ runQuery' progs root $ ghcMergedPkgOptions return ([setupConfigPath], opts) } @@ -61,11 +62,11 @@ helperProgs opts = Programs { -- -- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by -- 'resolveGmComponents'. -getComponents :: (Applicative m, MonadIO m, GmEnv m, GmLog m) +getComponents :: (Applicative m, IOish m, GmEnv m, GmLog m) => m [GmComponent 'GMCRaw ChEntrypoint] getComponents = chCached cabalHelperCache -chCached :: (Applicative m, MonadIO m, GmEnv m, GmLog m, Serialize a) +chCached :: (Applicative m, IOish m, GmEnv m, GmLog m, Serialize a) => Cached m (Programs, FilePath, (Version, [Char])) a -> m a chCached c = do root <- cradleRootDir <$> cradle @@ -87,7 +88,7 @@ cabalHelperCache => Cached m (Programs, FilePath, (Version, String)) [GmComponent 'GMCRaw ChEntrypoint] cabalHelperCache = Cached { cacheFile = cabalHelperCacheFile, - cachedAction = \ _ (progs, root, _) _ -> + cachedAction = \ _tcf (progs, root, _vers) _ma -> runQuery' progs root $ do q <- join7 <$> ghcOptions @@ -111,11 +112,11 @@ cabalHelperCache = Cached { , a == a' ] -withCabal :: (MonadIO m, GmEnv m) => m a -> m a +withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a withCabal action = do crdl <- cradle opts <- options - liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $ + whenM (liftIO $ isSetupConfigOutOfDate <$> getCurrentWorld crdl) $ withDirectory_ (cradleRootDir crdl) $ do let pkgDbArgs = "--package-db=clear" : map pkgDbArg (cradlePkgDbStack crdl) progOpts = @@ -126,8 +127,10 @@ withCabal action = do then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ] else [] ++ pkgDbArgs - void $ readProcess (T.cabalProgram opts) ("configure":progOpts) "" - writeAutogenFiles $ cradleRootDir crdl "dist" + gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project." + liftIO $ void $ readProcess (T.cabalProgram opts) ("configure":progOpts) "" + gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" + liftIO $ writeAutogenFiles $ cradleRootDir crdl "dist" action pkgDbArg :: GhcPkgDb -> String diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 24e62e4..3d0535f 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -261,7 +261,7 @@ findCandidates scns = foldl1 Set.intersection scns pickComponent :: Set ChComponentName -> ChComponentName pickComponent scn = Set.findMin scn -packageGhcOptions :: (Applicative m, MonadIO m, GmEnv m, GmLog m) => m [GHCOption] +packageGhcOptions :: (Applicative m, IOish m, GmEnv m, GmLog m) => m [GHCOption] packageGhcOptions = do crdl <- cradle case cradleCabalFile crdl of diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index e397ad0..c9da5a2 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -70,7 +70,7 @@ newTempDir :: FilePath -> IO FilePath newTempDir dir = flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory -whenM :: IO Bool -> IO () -> IO () +whenM :: Monad m => m Bool -> m () -> m () whenM mb ma = mb >>= flip when ma -- | Returns the path to the currently running ghc-mod executable. With ghc<7.6 From 84c0670fc44b205b2c9aa90684f1b5d582bd4638 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 3 Aug 2015 05:39:52 +0200 Subject: [PATCH 140/207] docs --- Language/Haskell/GhcMod/Caching.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs index 41e24b6..5de2ff1 100644 --- a/Language/Haskell/GhcMod/Caching.hs +++ b/Language/Haskell/GhcMod/Caching.hs @@ -25,9 +25,9 @@ data Cached m d a = Cached { -- optimizazion when knowing which input files changed can make updating the -- cache faster -- - -- * @data@: Arbitrary static input data can be used to invalidate the cache - -- using something other than file timestamps i.e. environment tool version - -- numbers + -- * @data@: Arbitrary static input data to cache action. Can be used to + -- invalidate the cache using something other than file timestamps + -- i.e. environment tool version numbers -- -- * @ma@: Cached data if it existed -- @@ -53,7 +53,7 @@ data TimedCacheFiles = TimedCacheFiles { } -- | Cache a MonadIO action with proper invalidation. -cached :: forall m a d. (MonadIO m, GmLog m, Serialize a, Eq d, Serialize d) +cached :: forall m a d. (MonadIO m, GmLog m, Serialize a, Eq d, Serialize d, Show d) => FilePath -- ^ Directory to prepend to 'cacheFile' -> Cached m d a -- ^ Cache descriptor -> d @@ -66,7 +66,7 @@ cached dir cd d = do writeCache (TimedCacheFiles tcfile []) Nothing "cache missing" Just (ifs, d', a) | d /= d' -> do tcf <- timeCacheInput dir (cacheFile cd) ifs - writeCache tcf (Just a) "input data changed" + writeCache tcf (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d' Just (ifs, _, a) -> do tcf <- timeCacheInput dir (cacheFile cd) ifs case invalidatingInputFiles tcf of From 614522644b69b6e5248b3425c856b78ea5117972 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 3 Aug 2015 07:51:23 +0200 Subject: [PATCH 141/207] Fix imports for ghc < 7.10 --- Language/Haskell/GhcMod/Gap.hs | 2 +- Language/Haskell/GhcMod/PathsAndFiles.hs | 2 +- Language/Haskell/GhcMod/Target.hs | 2 +- Language/Haskell/GhcMod/World.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 9ca8cd9..c8b6e0f 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -49,7 +49,7 @@ import CoreSyn (CoreExpr) import Data.List (intersperse) import Data.Maybe (catMaybes) import Data.Time.Clock (UTCTime) -import Data.Traversable +import Data.Traversable hiding (mapM) import DataCon (dataConRepType) import Desugar (deSugarExpr) import DynFlags diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index ebb5c4b..90b88ff 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -25,7 +25,7 @@ import Control.Monad import Data.List import Data.Char import Data.Maybe -import Data.Traversable +import Data.Traversable hiding (mapM) import Distribution.Helper (buildPlatform) import System.Directory import System.FilePath diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 7536b58..74b1f6c 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -44,7 +44,7 @@ import Data.Maybe import Data.Monoid as Monoid import Data.Either import Data.Foldable (foldrM) -import Data.Traversable +import Data.Traversable hiding (mapM, forM) import Data.IORef import Data.Map (Map) import qualified Data.Map as Map diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs index 9f77a0c..c9d6b49 100644 --- a/Language/Haskell/GhcMod/World.hs +++ b/Language/Haskell/GhcMod/World.hs @@ -7,7 +7,7 @@ import Language.Haskell.GhcMod.Utils import Control.Applicative import Data.Maybe -import Data.Traversable +import Data.Traversable hiding (mapM) import System.FilePath (()) import GHC.Paths (libdir) From c9b6e95a30bd41331674134fe857a0839e35221a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 3 Aug 2015 08:09:24 +0200 Subject: [PATCH 142/207] Add Vomit log level and dumping to disk --- Language/Haskell/GhcMod/Logging.hs | 26 +++++++++++++++++++++++--- Language/Haskell/GhcMod/Monad/Types.hs | 11 ++++++----- Language/Haskell/GhcMod/Pretty.hs | 1 + Language/Haskell/GhcMod/Target.hs | 8 +++++++- Language/Haskell/GhcMod/Types.hs | 1 + src/GHCMod.hs | 2 +- 6 files changed, 39 insertions(+), 10 deletions(-) diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index b6052c2..8f42b83 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -29,17 +29,25 @@ import Control.Monad import Control.Monad.Trans.Class import Data.List import Data.Char -import Data.Monoid (mempty, mappend, mconcat, (<>)) +import Data.Monoid +import Data.Maybe import System.IO +import System.FilePath import Text.PrettyPrint hiding (style, (<>)) import Prelude import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Pretty gmSetLogLevel :: GmLog m => GmLogLevel -> m () gmSetLogLevel level = - gmlJournal $ GhcModLog (Just level) [] + gmlJournal $ GhcModLog (Just level) (Last Nothing) [] + +gmSetDumpLevel :: GmLog m => Bool -> m () +gmSetDumpLevel level = + gmlJournal $ GhcModLog Nothing (Last (Just level)) [] + increaseLogLevel :: GmLogLevel -> GmLogLevel increaseLogLevel l | l == maxBound = l @@ -67,7 +75,19 @@ gmLog level loc' doc = do when (level <= level') $ liftIO $ hPutStrLn stderr msg - gmlJournal (GhcModLog Nothing [(level, loc', msgDoc)]) + gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)]) + +gmVomit :: (MonadIO m, GmLog m, GmEnv m) => String -> Doc -> String -> m () +gmVomit filename doc content = do + gmLog GmVomit "" $ doc <+> text content + + GhcModLog { gmLogVomitDump = Last mdump } + <- gmlHistory + + dir <- cradleTempDir `liftM` cradle + when (fromMaybe False mdump) $ + liftIO $ writeFile (dir filename) content + newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a } deriving (Functor, Applicative, Monad) diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 88519b3..e9343e7 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -112,14 +112,15 @@ data GhcModEnv = GhcModEnv { } data GhcModLog = GhcModLog { - gmLogLevel :: Maybe GmLogLevel, - gmLogMessages :: [(GmLogLevel, String, Doc)] + gmLogLevel :: Maybe GmLogLevel, + gmLogVomitDump :: Last Bool, + gmLogMessages :: [(GmLogLevel, String, Doc)] } deriving (Show) instance Monoid GhcModLog where - mempty = GhcModLog (Just GmPanic) mempty - GhcModLog ml a `mappend` GhcModLog ml' b = - GhcModLog (ml' `mplus` ml) (a `mappend` b) + mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty + GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' = + GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls') data GmGhcSession = GmGhcSession { gmgsOptions :: ![GHCOption], diff --git a/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs index d14512a..5526772 100644 --- a/Language/Haskell/GhcMod/Pretty.hs +++ b/Language/Haskell/GhcMod/Pretty.hs @@ -45,6 +45,7 @@ gmLogLevelDoc GmError = text "ERROR" gmLogLevelDoc GmWarning = text "Warning" gmLogLevelDoc GmInfo = text "info" gmLogLevelDoc GmDebug = text "DEBUG" +gmLogLevelDoc GmVomit = text "VOMIT" infixl 6 <+>: (<+>:) :: Doc -> Doc -> Doc diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 74b1f6c..163adba 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -150,6 +150,11 @@ runGmlTWith efnmns' mdf wrapper action = do opts <- targetGhcOptions crdl serfnmn let opts' = opts ++ ["-O0"] ++ ghcUserOptions + gmVomit + "session-ghc-options" + (strDoc "Initializing GHC session with following options") + (show opts') + initSession opts' $ setModeSimple >>> setEmptyLogger >>> mdf @@ -220,7 +225,8 @@ resolvedComponentsCache = Cached { (False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs } _ -> return () --- liftIO $ print ("changed files", mums :: Maybe [Either FilePath ()]) + gmLog GmDebug "resolvedComponentsCache" $ + strDoc "files changed" <+>: text (show (mums :: Maybe [Either FilePath ()])) mcs <- resolveGmComponents mums comps return (setupConfigPath:flatten mcs , mcs) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 416c04c..1fb7230 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -170,6 +170,7 @@ data GmLogLevel = | GmWarning | GmInfo | GmDebug + | GmVomit deriving (Eq, Ord, Enum, Bounded, Show, Read) -- | Collection of packages diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 50be2b1..cf4cfe4 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -237,7 +237,7 @@ intToLogLevel = toEnum globalArgSpec :: [OptDescr (Options -> Options)] globalArgSpec = - [ option "v" ["verbose"] "Increase or set log level. (0-6)" $ + [ option "v" ["verbose"] "Increase or set log level. (0-7)" $ optArg "LEVEL" $ \ml o -> o { logLevel = case ml of Nothing -> increaseLogLevel (logLevel o) From d270e92951dca3c170bb64d7d272fccc14dd7533 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 5 Aug 2015 04:06:22 +0200 Subject: [PATCH 143/207] Clean up L.H.GM.Target debug/vomit output a bit --- Language/Haskell/GhcMod/Logging.hs | 2 +- Language/Haskell/GhcMod/Target.hs | 17 +++++++++++++---- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 8f42b83..7c1c7fa 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -79,7 +79,7 @@ gmLog level loc' doc = do gmVomit :: (MonadIO m, GmLog m, GmEnv m) => String -> Doc -> String -> m () gmVomit filename doc content = do - gmLog GmVomit "" $ doc <+> text content + gmLog GmVomit "" $ doc <+>: text content GhcModLog { gmLogVomitDump = Last mdump } <- gmlHistory diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 163adba..a5659f0 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -43,9 +43,10 @@ import Language.Haskell.GhcMod.Utils import Data.Maybe import Data.Monoid as Monoid import Data.Either -import Data.Foldable (foldrM) +import Data.Foldable as Foldable (foldrM, concat) import Data.Traversable hiding (mapM, forM) import Data.IORef +import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -152,8 +153,8 @@ runGmlTWith efnmns' mdf wrapper action = do gmVomit "session-ghc-options" - (strDoc "Initializing GHC session with following options") - (show opts') + (text "Initializing GHC session with following options") + (intercalate " " $ map (("\""++) . (++"\"")) opts') initSession opts' $ setModeSimple >>> setEmptyLogger >>> mdf @@ -207,6 +208,7 @@ resolvedComponentsCache = Cached { cachedAction = \tcfs comps ma -> do Cradle {..} <- cradle let iifsM = invalidatingInputFiles tcfs + mums :: Maybe [Either FilePath ModuleName] mums = case iifsM of Nothing -> Nothing @@ -225,8 +227,15 @@ resolvedComponentsCache = Cached { (False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs } _ -> return () + let mdesc (Left f) = "file:" ++ f + mdesc (Right mn) = "module:" ++ moduleNameString mn + + changed = map (text . mdesc) $ Foldable.concat mums + changedDoc | [] <- changed = text "none" + | otherwise = sep changed + gmLog GmDebug "resolvedComponentsCache" $ - strDoc "files changed" <+>: text (show (mums :: Maybe [Either FilePath ()])) + text "files changed" <+>: changedDoc mcs <- resolveGmComponents mums comps return (setupConfigPath:flatten mcs , mcs) From 40f0e21fdf381d9a807bcdcba42b48bbbbc5bec6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 5 Aug 2015 04:06:41 +0200 Subject: [PATCH 144/207] Fix input validation on log level --- src/GHCMod.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index cf4cfe4..ce66c08 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -241,7 +241,7 @@ globalArgSpec = optArg "LEVEL" $ \ml o -> o { logLevel = case ml of Nothing -> increaseLogLevel (logLevel o) - Just l -> toEnum $ min 6 $ read l + Just l -> toEnum $ min 7 $ read l } , option "s" [] "Be silent, set log level to 0" $ From 1a53582a216147fe3f5d79fadda151cb149b9bdd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 5 Aug 2015 04:05:43 +0200 Subject: [PATCH 145/207] Add failing test for missing warnings #507 --- ghc-mod.cabal | 1 + test/CheckSpec.hs | 5 +++++ test/data/check-missing-warnings/DesugarWarnings.hs | 5 +++++ 3 files changed, 11 insertions(+) create mode 100644 test/data/check-missing-warnings/DesugarWarnings.hs diff --git a/ghc-mod.cabal b/ghc-mod.cabal index d34566c..8891657 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -71,6 +71,7 @@ Extra-Source-Files: ChangeLog test/data/pattern-synonyms/*.hs test/data/quasi-quotes/*.hs test/data/template-haskell/*.hs + test/data/check-missing-warnings/*.hs Library Default-Language: Haskell2010 diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index f240f98..91dbfa9 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -52,3 +52,8 @@ spec = do withDirectory_ "test/data/ghc-mod-check/lib/Data" $ do res <- runD $ checkSyntax ["Foo.hs"] res `shouldBe` "" + + it "emits warnings generated in GHC's desugar stage" $ do + withDirectory_ "test/data/check-missing-warnings" $ do + res <- runD $ checkSyntax ["DesugarWarnings.hs"] + res `shouldBe` "test/data/check-missing-warnings/DesugarWarnings.hs:5:9:Warning: Pattern match(es) are non-exhaustiveIn a case alternative: Patterns not matched: _ : _" diff --git a/test/data/check-missing-warnings/DesugarWarnings.hs b/test/data/check-missing-warnings/DesugarWarnings.hs new file mode 100644 index 0000000..9d80559 --- /dev/null +++ b/test/data/check-missing-warnings/DesugarWarnings.hs @@ -0,0 +1,5 @@ +module Warnings (zoo) where + +zoo :: [a] -> () +zoo x = case x of + [] -> undefined From 6e28e07ca96ddb544a164319bd8a1da021cbd12c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 5 Aug 2015 06:15:44 +0200 Subject: [PATCH 146/207] Fix #507 --- Language/Haskell/GhcMod/Target.hs | 4 +++- test/CheckSpec.hs | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index a5659f0..7b1fc6c 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -43,7 +43,8 @@ import Language.Haskell.GhcMod.Utils import Data.Maybe import Data.Monoid as Monoid import Data.Either -import Data.Foldable as Foldable (foldrM, concat) +import Data.Foldable as Foldable (foldrM) +import qualified Data.Foldable as Foldable import Data.Traversable hiding (mapM, forM) import Data.IORef import Data.List @@ -435,6 +436,7 @@ loadTargets filesOrModules = do where loadTargets' Simple = do void $ load LoadAllTargets + mapM_ (parseModule >=> typecheckModule >=> desugarModule) =<< getModuleGraph loadTargets' Intelligent = do df <- getSessionDynFlags diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index 91dbfa9..7eaa4d8 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -56,4 +56,4 @@ spec = do it "emits warnings generated in GHC's desugar stage" $ do withDirectory_ "test/data/check-missing-warnings" $ do res <- runD $ checkSyntax ["DesugarWarnings.hs"] - res `shouldBe` "test/data/check-missing-warnings/DesugarWarnings.hs:5:9:Warning: Pattern match(es) are non-exhaustiveIn a case alternative: Patterns not matched: _ : _" + res `shouldBe` "DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched: _ : _\n" From 20bccae1fc0cab16c2a3286e91a0c68026cdb293 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 5 Aug 2015 06:20:55 +0200 Subject: [PATCH 147/207] Enable travis caching for cabal dependencies --- .travis.yml | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 662cf7b..988d705 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,8 +4,23 @@ ghc: - 7.6 - 7.8 +sudo: false + +addons: + apt: + packages: + - zlib1g-dev + +cache: + apt: true + directories: + - ~/.cabal + - ~/.ghc + +before_cache: + - rm -f $HOME/.cabal/logs $HOME/.cabal/packages/*/build-reports.log + install: - - sudo apt-get install zlib1g-dev - cabal update # - ( $CABAL122 && cabal install cabal-install --constraint "Cabal >= 1.22" && ghc-pkg unregister Cabal ) || true - echo $PATH @@ -13,6 +28,8 @@ install: - if [ -n "$(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | tail -n1 | sed -n '/^1.18/p')" ]; then cabal install cabal-install --constraint "Cabal == 1.18.* && > 1.18.0"; fi - cabal install happy - happy --version + - ls -lR ~/.ghc + - ls -lR ~/.cabal - cabal install -j --only-dependencies --enable-tests script: From f61dd0a9e635d3c361c4f6d752b14f711c841afc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 5 Aug 2015 08:52:52 +0200 Subject: [PATCH 148/207] Fix re-init of ghc-modi session after environment change Using `dropSession` instead of a weird exception cludge --- Language/Haskell/GhcMod.hs | 2 ++ Language/Haskell/GhcMod/Target.hs | 6 +++-- src/GHCMod.hs | 16 ++++++------- src/Misc.hs | 39 +------------------------------ 4 files changed, 14 insertions(+), 49 deletions(-) diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 763384e..516ffa2 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -28,6 +28,7 @@ module Language.Haskell.GhcMod ( -- * Monad utilities , runGhcModT , withOptions + , dropSession -- * 'GhcMod' utilities , boot , browse @@ -73,3 +74,4 @@ import Language.Haskell.GhcMod.Modules import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Target diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 7b1fc6c..93afccc 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -110,6 +110,8 @@ initSession opts mdf = do _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags getSession +-- | Drop the currently active GHC session, the next that requires a GHC session +-- will initialize a new one. dropSession :: IOish m => GhcModT m () dropSession = do s <- gmsGet @@ -120,10 +122,10 @@ dropSession = do liftIO $ writeIORef ref (error "HscEnv: session was dropped") -- Not available on ghc<7.8; didn't really help anyways -- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped") - + gmsPut s { gmGhcSession = Nothing } Nothing -> return () - gmsPut s { gmGhcSession = Nothing } + runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a runGmlT fns action = runGmlT' fns return action diff --git a/src/GHCMod.hs b/src/GHCMod.hs index ce66c08..43a2e8a 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -341,12 +341,11 @@ progMain (globalOptions,cmdArgs) = do -- ghc-modi legacyInteractive :: IOish m => GhcModT m () -legacyInteractive = - liftIO emptyNewUnGetLine >>= \ref -> do +legacyInteractive = do opt <- options symdbreq <- liftIO $ newSymDbReq opt world <- liftIO . getCurrentWorld =<< cradle - legacyInteractiveLoop symdbreq ref world + legacyInteractiveLoop symdbreq world bug :: String -> IO () bug msg = do @@ -363,19 +362,18 @@ replace :: String -> String -> String -> String replace needle replacement = intercalate replacement . splitOn needle legacyInteractiveLoop :: IOish m - => SymDbReq -> UnGetLine -> World -> GhcModT m () -legacyInteractiveLoop symdbreq ref world = do + => SymDbReq -> World -> GhcModT m () +legacyInteractiveLoop symdbreq world = do liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle -- blocking - cmdArg <- liftIO $ getCommand ref + cmdArg <- liftIO $ getLine -- after blocking, we need to see if the world has changed. changed <- liftIO . didWorldChange world =<< cradle when changed $ do - liftIO $ ungetCommand ref cmdArg - throw Restart + dropSession let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg arg = concat args' @@ -405,7 +403,7 @@ legacyInteractiveLoop symdbreq ref world = do _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" liftIO $ putStr res >> putStrLn "OK" >> hFlush stdout - legacyInteractiveLoop symdbreq ref world + legacyInteractiveLoop symdbreq world globalCommands :: [String] -> Maybe String globalCommands [] = Nothing diff --git a/src/Misc.hs b/src/Misc.hs index 6b6fbcf..dc63ed0 100644 --- a/src/Misc.hs +++ b/src/Misc.hs @@ -1,13 +1,7 @@ {-# LANGUAGE DeriveDataTypeable, CPP #-} module Misc ( - GHCModiError(..) - , Restart(..) - , UnGetLine - , emptyNewUnGetLine - , ungetCommand - , getCommand - , SymDbReq + SymDbReq , newSymDbReq , getDb , checkDb @@ -26,37 +20,6 @@ import Language.Haskell.GhcMod.Internal ---------------------------------------------------------------- -data GHCModiError = CmdArg [String] deriving (Show, Typeable) - -instance Exception GHCModiError - ----------------------------------------------------------------- - -data Restart = Restart deriving (Show, Typeable) - -instance Exception Restart - ----------------------------------------------------------------- - -newtype UnGetLine = UnGetLine (IORef (Maybe String)) - -emptyNewUnGetLine :: IO UnGetLine -emptyNewUnGetLine = UnGetLine <$> newIORef Nothing - -ungetCommand :: UnGetLine -> String -> IO () -ungetCommand (UnGetLine ref) cmd = writeIORef ref (Just cmd) - -getCommand :: UnGetLine -> IO String -getCommand (UnGetLine ref) = do - mcmd <- readIORef ref - case mcmd of - Nothing -> getLine - Just cmd -> do - writeIORef ref Nothing - return cmd - ----------------------------------------------------------------- - type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog) data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction) From aabbd5ce335d0a523f9bf7c553aefcc50d4371bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 5 Aug 2015 10:16:27 +0200 Subject: [PATCH 149/207] Fix resolveModule Cpp test --- test/TargetSpec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/TargetSpec.hs b/test/TargetSpec.hs index e75807c..36e1bed 100644 --- a/test/TargetSpec.hs +++ b/test/TargetSpec.hs @@ -40,8 +40,8 @@ spec = do describe "resolveModule" $ do it "Works when a module given as path uses CPP" $ do dir <- getCurrentDirectory - print dir let srcDirs = [dir "test/data/target/src"] withLightHscEnv [] $ \env -> runNullLog $ do - Just _ <- resolveModule env srcDirs (Left $ dir "test/data/target/src/A/B/C/D/E.hs") + x <- resolveModule env srcDirs (Left $ dir "test/data/target/Cpp.hs") + x `shouldBe` Just (ModulePath "test/data/target/Cpp.hs" "Cpp") return () From a9c46c08f66ba153ed69f670a2dba778f9b6964c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 5 Aug 2015 10:29:19 +0200 Subject: [PATCH 150/207] Fix warnings --- src/Misc.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Misc.hs b/src/Misc.hs index dc63ed0..834f0c2 100644 --- a/src/Misc.hs +++ b/src/Misc.hs @@ -7,12 +7,9 @@ module Misc ( , checkDb ) where -import Control.Applicative import Control.Concurrent.Async (Async, async, wait) -import Control.Exception (Exception) import CoreMonad (liftIO) import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.Typeable (Typeable) import Prelude import Language.Haskell.GhcMod From 2b7d25c7a58000c1aabbe232701d5b75d05c2937 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 5 Aug 2015 10:29:48 +0200 Subject: [PATCH 151/207] Remove debug stuff from .travis.yml --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 988d705..1f784ea 100644 --- a/.travis.yml +++ b/.travis.yml @@ -28,8 +28,8 @@ install: - if [ -n "$(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | tail -n1 | sed -n '/^1.18/p')" ]; then cabal install cabal-install --constraint "Cabal == 1.18.* && > 1.18.0"; fi - cabal install happy - happy --version - - ls -lR ~/.ghc - - ls -lR ~/.cabal +# - ls -lR ~/.ghc +# - ls -lR ~/.cabal - cabal install -j --only-dependencies --enable-tests script: From 2c9b79449a1d6133f291273c378d2ddef011503b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 6 Aug 2015 04:16:21 +0200 Subject: [PATCH 152/207] Add missing test data to extra-source-files --- ghc-mod.cabal | 1 + test/data/target/Cpp.hs | 7 +++++++ 2 files changed, 8 insertions(+) create mode 100644 test/data/target/Cpp.hs diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 8891657..ace73ba 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -71,6 +71,7 @@ Extra-Source-Files: ChangeLog test/data/pattern-synonyms/*.hs test/data/quasi-quotes/*.hs test/data/template-haskell/*.hs + test/data/target/*.hs test/data/check-missing-warnings/*.hs Library diff --git a/test/data/target/Cpp.hs b/test/data/target/Cpp.hs new file mode 100644 index 0000000..5a17b7a --- /dev/null +++ b/test/data/target/Cpp.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +#undef NOTHING +#ifdef NOTHING +module WRONG_MODULE where +#else +module Cpp where +#endif From 31d85a27b47b3f8969db55d3d0444d8eac859be8 Mon Sep 17 00:00:00 2001 From: meditans Date: Thu, 6 Aug 2015 11:49:01 +0200 Subject: [PATCH 153/207] Added logging in `refine` and `auto` handlers --- Language/Haskell/GhcMod/FillSig.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index b1700eb..246baaa 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -12,6 +12,7 @@ import Data.Function (on) import Data.List (find, nub, sortBy) import qualified Data.Map as M import Data.Maybe (catMaybes) +import Text.PrettyPrint (($$), text, nest) import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) @@ -22,6 +23,8 @@ import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils +import Language.Haskell.GhcMod.Logging (gmLog) +import Language.Haskell.GhcMod.Pretty (showDoc) import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.Types import Outputable (PprStyle) @@ -356,7 +359,10 @@ refine file lineNo colNo (Expression expr) = text = initialHead1 expr iArgs (infinitePrefixSupply name) in (fourInts loc, doParen paren text) where - handler (SomeException _) = emptyResult =<< options + handler (SomeException ex) = do + gmLog GmDebug "refining" $ + text "" $$ nest 4 (showDoc ex) + emptyResult =<< options -- Look for the variable in the specified position findVar @@ -442,7 +448,10 @@ auto file lineNo colNo = return ( fourInts loc , map (doParen paren) $ nub (djinnsEmpty ++ djinns)) where - handler (SomeException _) = emptyResult =<< options + handler (SomeException ex) = do + gmLog GmDebug "auto-refining" $ + text "" $$ nest 4 (showDoc ex) + emptyResult =<< options -- Functions we do not want in completions notWantedFuns :: [String] From 9dc7a9375e58cb2d0960ee0306f92113e81bea04 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 6 Aug 2015 05:18:57 +0200 Subject: [PATCH 154/207] Fix resolveModule test again --- test/TargetSpec.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/test/TargetSpec.hs b/test/TargetSpec.hs index 36e1bed..5fc1466 100644 --- a/test/TargetSpec.hs +++ b/test/TargetSpec.hs @@ -41,7 +41,6 @@ spec = do it "Works when a module given as path uses CPP" $ do dir <- getCurrentDirectory let srcDirs = [dir "test/data/target/src"] - withLightHscEnv [] $ \env -> runNullLog $ do - x <- resolveModule env srcDirs (Left $ dir "test/data/target/Cpp.hs") - x `shouldBe` Just (ModulePath "test/data/target/Cpp.hs" "Cpp") - return () + x <- withLightHscEnv [] $ \env -> runNullLog $ do + resolveModule env srcDirs (Left $ dir "test/data/target/Cpp.hs") + liftIO $ x `shouldBe` Just (ModulePath "Cpp" $ dir "test/data/target/Cpp.hs") From f85327a1b6ce12cba544cdf2532ce0ca07181e1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 7 Aug 2015 04:13:12 +0200 Subject: [PATCH 155/207] Re-enable cabal-helper tests --- test/CabalHelperSpec.hs | 71 ++++++++++++++++++++++------------------- 1 file changed, 38 insertions(+), 33 deletions(-) diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs index 9e832c2..6acdde3 100644 --- a/test/CabalHelperSpec.hs +++ b/test/CabalHelperSpec.hs @@ -2,16 +2,17 @@ module CabalHelperSpec where import Control.Arrow import Control.Applicative --- import Language.Haskell.GhcMod.CabalHelper --- import Language.Haskell.GhcMod.PathsAndFiles +import Distribution.Helper +import Language.Haskell.GhcMod.CabalHelper +import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Error import Test.Hspec --- import System.Directory --- import System.FilePath --- import System.Process (readProcess) +import System.Directory +import System.FilePath +import System.Process (readProcess) --- import Dir --- import TestUtils +import Dir +import TestUtils import Data.List import Config (cProjectVersionInt) @@ -36,35 +37,39 @@ idirOpts :: [(c, [String])] -> [(c, [String])] idirOpts = map (second $ map (drop 2) . filter ("-i"`isPrefixOf`)) spec :: Spec -spec = do return () - -- describe "getGhcOptions" $ do - -- it "throws an exception if the cabal file is broken" $ do - -- let tdir = "test/data/broken-caba" - -- runD' tdir getGhcOptions `shouldThrow` anyIOException +spec = do + describe "getComponents" $ do + it "throws an exception if the cabal file is broken" $ do + let tdir = "test/data/broken-cabal" + runD' tdir getComponents `shouldThrow` anyIOException - -- it "handles sandboxes correctly" $ do - -- let tdir = "test/data/cabal-project" - -- cwd <- getCurrentDirectory + it "handles sandboxes correctly" $ do + let tdir = "test/data/cabal-project" + cwd <- getCurrentDirectory - -- opts <- runD' tdir getGhcOptions + -- TODO: ChSetupHsName should also have sandbox stuff, see related + -- comment in cabal-helper + opts <- map gmcGhcOpts . filter ((/= ChSetupHsName) . gmcName) <$> runD' tdir getComponents - -- if ghcVersion < 706 - -- then forM_ opts (\(_, o) -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) - -- else forM_ opts (\(_, o) -> o `shouldContain` ["-no-user-package-db","-package-db",cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) + print opts - -- it "extracts build dependencies" $ do - -- let tdir = "test/data/cabal-project" - -- opts <- runD' tdir getGhcOptions - -- let ghcOpts = snd $ head opts - -- pkgs = pkgOptions ghcOpts - -- pkgs `shouldBe` ["Cabal","base","template-haskell"] + if ghcVersion < 706 + then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) + else forM_ opts (\o -> o `shouldContain` ["-no-user-package-db","-package-db",cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) - -- it "uses non default flags" $ do - -- let tdir = "test/data/cabal-flags" - -- _ <- withDirectory_ tdir $ - -- readProcess "cabal" ["configure", "-ftest-flag"] "" + it "extracts build dependencies" $ do + let tdir = "test/data/cabal-project" + opts <- map gmcGhcOpts <$> runD' tdir getComponents + let ghcOpts = head opts + pkgs = pkgOptions ghcOpts + pkgs `shouldBe` ["Cabal","base","template-haskell"] - -- opts <- runD' tdir getGhcOptions - -- let ghcOpts = snd $ head opts - -- pkgs = pkgOptions ghcOpts - -- pkgs `shouldBe` ["Cabal","base"] + it "uses non default flags" $ do + let tdir = "test/data/cabal-flags" + _ <- withDirectory_ tdir $ + readProcess "cabal" ["configure", "-ftest-flag"] "" + + opts <- map gmcGhcOpts <$> runD' tdir getComponents + let ghcOpts = head opts + pkgs = pkgOptions ghcOpts + pkgs `shouldBe` ["Cabal","base"] From 8439f12cb022ca39e7bcf4460433f31a5be013cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 7 Aug 2015 06:47:34 +0200 Subject: [PATCH 156/207] Let Cabal determine the package-db stack --- Language/Haskell/GhcMod/CabalHelper.hs | 136 +++++++++++++----- Language/Haskell/GhcMod/Cradle.hs | 26 ---- Language/Haskell/GhcMod/Find.hs | 9 +- Language/Haskell/GhcMod/GhcPkg.hs | 12 +- Language/Haskell/GhcMod/PathsAndFiles.hs | 68 +++++---- Language/Haskell/GhcMod/PkgDoc.hs | 15 +- Language/Haskell/GhcMod/Target.hs | 16 ++- Language/Haskell/GhcMod/Types.hs | 9 +- Language/Haskell/GhcMod/World.hs | 47 +++--- ghc-mod.cabal | 7 +- src/GHCMod.hs | 4 +- test/CabalHelperSpec.hs | 26 +++- test/CradleSpec.hs | 17 --- test/Main.hs | 3 + test/data/custom-cradle/custom-cradle.cabal | 12 ++ test/data/custom-cradle/dummy.cabal | 1 - test/data/custom-cradle/ghc-mod.cradle | 5 - .../custom-cradle/ghc-mod.package-db-stack | 5 + test/data/custom-cradle/package-db-a/.gitkeep | 0 test/data/custom-cradle/package-db-b/.gitkeep | 0 test/data/custom-cradle/package-db-c/.gitkeep | 0 21 files changed, 247 insertions(+), 171 deletions(-) create mode 100644 test/data/custom-cradle/custom-cradle.cabal delete mode 100644 test/data/custom-cradle/dummy.cabal delete mode 100644 test/data/custom-cradle/ghc-mod.cradle create mode 100644 test/data/custom-cradle/ghc-mod.package-db-stack create mode 100644 test/data/custom-cradle/package-db-a/.gitkeep create mode 100644 test/data/custom-cradle/package-db-b/.gitkeep create mode 100644 test/data/custom-cradle/package-db-c/.gitkeep diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 2f51ebb..9c0ad95 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -15,23 +15,28 @@ -- along with this program. If not, see . {-# LANGUAGE CPP #-} -module Language.Haskell.GhcMod.CabalHelper ( - getComponents +module Language.Haskell.GhcMod.CabalHelper +#ifndef SPEC + ( getComponents , getGhcMergedPkgOptions - ) where + , getPackageDbStack + ) +#endif + where import Control.Applicative import Control.Monad +import Data.Maybe import Data.Monoid import Data.Version import Data.Serialize (Serialize) +import Data.Traversable import Distribution.Helper import qualified Language.Haskell.GhcMod.Types as T import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram, cabalProgram) import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.World import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Logging import System.FilePath @@ -50,12 +55,35 @@ getGhcMergedPkgOptions = chCached Cached { return ([setupConfigPath], opts) } -helperProgs :: Options -> Programs -helperProgs opts = Programs { - cabalProgram = T.cabalProgram opts, - ghcProgram = T.ghcProgram opts, - ghcPkgProgram = T.ghcPkgProgram opts - } +parseCustomPackageDb :: String -> [GhcPkgDb] +parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src + where + parsePkgDb "global" = GlobalDb + parsePkgDb "user" = UserDb + parsePkgDb s = PackageDb s + +getCustomPkgDbStack :: (IOish m, GmEnv m) => m (Maybe [GhcPkgDb]) +getCustomPkgDbStack = do + mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle + return $ parseCustomPackageDb <$> mCusPkgDbFile + +getPackageDbStack :: (IOish m, GmEnv m, GmLog m) => m [GhcPkgDb] +getPackageDbStack = do + mCusPkgStack <- getCustomPkgDbStack + flip fromMaybe mCusPkgStack <$> getPackageDbStack' + +getPackageDbStack' :: (IOish m, GmEnv m, GmLog m) => m [GhcPkgDb] +getPackageDbStack' = chCached Cached { + cacheFile = pkgDbStackCacheFile, + cachedAction = \ _tcf (progs, root, _) _ma -> do + dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery' progs root packageDbStack + return ([setupConfigPath, sandboConfigFile], dbs) + } + +chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb +chPkgToGhcPkg ChPkgGlobal = GlobalDb +chPkgToGhcPkg ChPkgUser = UserDb +chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f -- | Primary interface to cabal-helper and intended single entrypoint to -- constructing 'GmComponent's @@ -66,23 +94,6 @@ getComponents :: (Applicative m, IOish m, GmEnv m, GmLog m) => m [GmComponent 'GMCRaw ChEntrypoint] getComponents = chCached cabalHelperCache -chCached :: (Applicative m, IOish m, GmEnv m, GmLog m, Serialize a) - => Cached m (Programs, FilePath, (Version, [Char])) a -> m a -chCached c = do - root <- cradleRootDir <$> cradle - d <- cacheInputData root - withCabal $ cached root c d - where - cacheInputData root = do - opt <- options - return $ ( helperProgs opt - , root "dist" - , (gmVer, chVer) - ) - - gmVer = GhcMod.version - chVer = VERSION_cabal_helper - cabalHelperCache :: (Functor m, Applicative m, MonadIO m) => Cached m (Programs, FilePath, (Version, String)) [GmComponent 'GMCRaw ChEntrypoint] @@ -116,18 +127,37 @@ withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a withCabal action = do crdl <- cradle opts <- options - whenM (liftIO $ isSetupConfigOutOfDate <$> getCurrentWorld crdl) $ + mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl + mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) + + mCusPkgDbStack <- getCustomPkgDbStack + + pkgDbStackOutOfSync <- + case mCusPkgDbStack of + Just cusPkgDbStack -> do + pkgDb <- runQuery' (helperProgs opts) (cradleRootDir crdl "dist") $ + map chPkgToGhcPkg <$> packageDbStack + return $ pkgDb /= cusPkgDbStack + + Nothing -> return False + + cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack + + when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $ + gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project." + when pkgDbStackOutOfSync $ + gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack, reconfiguring Cabal project." + + when (isSetupConfigOutOfDate mCabalFile mCabalConfig || pkgDbStackOutOfSync) $ withDirectory_ (cradleRootDir crdl) $ do - let pkgDbArgs = "--package-db=clear" : map pkgDbArg (cradlePkgDbStack crdl) - progOpts = + let progOpts = [ "--with-ghc=" ++ T.ghcProgram opts ] -- Only pass ghc-pkg if it was actually set otherwise we -- might break cabal's guessing logic ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ] else [] - ++ pkgDbArgs - gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project." + ++ map pkgDbArg cusPkgStack liftIO $ void $ readProcess (T.cabalProgram opts) ("configure":progOpts) "" gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" liftIO $ writeAutogenFiles $ cradleRootDir crdl "dist" @@ -137,3 +167,45 @@ pkgDbArg :: GhcPkgDb -> String pkgDbArg GlobalDb = "--package-db=global" pkgDbArg UserDb = "--package-db=user" pkgDbArg (PackageDb p) = "--package-db=" ++ p + +-- * Neither file exists -> should return False: +-- @Nothing < Nothing = False@ +-- (since we don't need to @cabal configure@ when no cabal file exists.) +-- +-- * Cabal file doesn't exist (unlikely case) -> should return False +-- @Just cc < Nothing = False@ +-- TODO: should we delete dist/setup-config? +-- +-- * dist/setup-config doesn't exist yet -> should return True: +-- @Nothing < Just cf = True@ +-- +-- * Both files exist +-- @Just cc < Just cf = cc < cf = cc `olderThan` cf@ +isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool +isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do + worldCabalConfig < worldCabalFile + + +helperProgs :: Options -> Programs +helperProgs opts = Programs { + cabalProgram = T.cabalProgram opts, + ghcProgram = T.ghcProgram opts, + ghcPkgProgram = T.ghcPkgProgram opts + } + +chCached :: (Applicative m, IOish m, GmEnv m, GmLog m, Serialize a) + => Cached m (Programs, FilePath, (Version, [Char])) a -> m a +chCached c = do + root <- cradleRootDir <$> cradle + d <- cacheInputData root + withCabal $ cached root c d + where + cacheInputData root = do + opt <- options + return $ ( helperProgs opt + , root "dist" + , (gmVer, chVer) + ) + + gmVer = GhcMod.version + chVer = VERSION_cabal_helper diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index d409ce7..4a23fab 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -57,14 +57,11 @@ customCradle :: FilePath -> MaybeT IO Cradle customCradle wdir = do cabalFile <- MaybeT $ findCabalFile wdir let cabalDir = takeDirectory cabalFile - cradleFile <- MaybeT $ findCradleFile cabalDir - pkgDbStack <- liftIO $ parseCradle cradleFile return Cradle { cradleCurrentDir = wdir , cradleRootDir = cabalDir , cradleTempDir = error "tmpDir" , cradleCabalFile = Just cabalFile - , cradlePkgDbStack = pkgDbStack } cabalCradle :: FilePath -> MaybeT IO Cradle @@ -72,26 +69,22 @@ cabalCradle wdir = do cabalFile <- MaybeT $ findCabalFile wdir let cabalDir = takeDirectory cabalFile - pkgDbStack <- liftIO $ getPackageDbStack cabalDir return Cradle { cradleCurrentDir = wdir , cradleRootDir = cabalDir , cradleTempDir = error "tmpDir" , cradleCabalFile = Just cabalFile - , cradlePkgDbStack = pkgDbStack } sandboxCradle :: FilePath -> MaybeT IO Cradle sandboxCradle wdir = do sbDir <- MaybeT $ findCabalSandboxDir wdir - pkgDbStack <- liftIO $ getPackageDbStack sbDir return Cradle { cradleCurrentDir = wdir , cradleRootDir = sbDir , cradleTempDir = error "tmpDir" , cradleCabalFile = Nothing - , cradlePkgDbStack = pkgDbStack } plainCradle :: FilePath -> MaybeT IO Cradle @@ -101,23 +94,4 @@ plainCradle wdir = do , cradleRootDir = wdir , cradleTempDir = error "tmpDir" , cradleCabalFile = Nothing - , cradlePkgDbStack = [GlobalDb, UserDb] } - -getPackageDbStack :: FilePath -- ^ Project Directory (where the - -- cabal.sandbox.config file would be if it - -- exists) - -> IO [GhcPkgDb] -getPackageDbStack cdir = - ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir - -parseCradle :: FilePath -> IO [GhcPkgDb] -parseCradle path = do - source <- readFile path - return $ parseCradle' source - where - parseCradle' source = map parsePkgDb $ filter (not . null) $ lines source - - parsePkgDb "global" = GlobalDb - parsePkgDb "user" = UserDb - parsePkgDb s = PackageDb s diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 11228f5..1275656 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -15,7 +15,7 @@ module Language.Haskell.GhcMod.Find where import Control.Applicative -import Control.Monad (when, void, (<=<)) +import Control.Monad (when, void) import Data.Function (on) import Data.List (groupBy, sort) import qualified GHC as G @@ -46,9 +46,9 @@ data SymbolDb = SymbolDb , symbolDbCachePath :: FilePath } deriving (Show) -isOutdated :: (GmEnv m, IOish m) => SymbolDb -> m Bool +isOutdated :: IOish m => SymbolDb -> GhcModT m Bool isOutdated db = - liftIO . (isOlderThan (symbolDbCachePath db) <=< timedPackageCaches) =<< cradle + (liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches ---------------------------------------------------------------- @@ -94,9 +94,8 @@ loadSymbolDb = do dumpSymbol :: IOish m => FilePath -> GhcModT m String dumpSymbol dir = do - crdl <- cradle + create <- (liftIO . isOlderThan cache) =<< timedPackageCaches runGmPkgGhc $ do - create <- liftIO $ isOlderThan cache =<< timedPackageCaches crdl when create $ liftIO . writeSymbolCache cache =<< getGlobalSymbolTable return $ unlines [cache] diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index 3114916..4418830 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -12,11 +12,14 @@ import Control.Applicative import Data.List.Split (splitOn) import Data.Maybe import Exception (handleIO) -import Language.Haskell.GhcMod.Types import System.Directory (doesDirectoryExist, getAppUserDataDirectory) import System.FilePath (()) import Prelude +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.CabalHelper + ghcVersion :: Int ghcVersion = read cProjectVersionInt @@ -54,9 +57,10 @@ ghcDbOpt (PackageDb pkgDb) ---------------------------------------------------------------- -getPackageCachePaths :: FilePath -> Cradle -> IO [FilePath] -getPackageCachePaths sysPkgCfg crdl = - catMaybes <$> resolvePackageConfig sysPkgCfg `mapM` cradlePkgDbStack crdl +getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath] +getPackageCachePaths sysPkgCfg = do + pkgDbStack <- getPackageDbStack + catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack -- TODO: use PkgConfRef --- Copied from ghc module `Packages' unfortunately it's not exported :/ diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 90b88ff..527eb21 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -71,6 +71,33 @@ findCabalFile dir = do appendDir :: DirPath -> [FileName] -> [FilePath] appendDir d fs = (d ) `map` fs +-- | Get path to sandbox config file +getSandboxDb :: FilePath + -- ^ Path to the cabal package root directory (containing the + -- @cabal.sandbox.config@ file) + -> IO (Maybe GhcPkgDb) +getSandboxDb d = do + mConf <- traverse readFile =<< mightExist (d "cabal.sandbox.config") + return $ PackageDb . fixPkgDbVer <$> (extractSandboxDbDir =<< mConf) + + where + fixPkgDbVer dir = + case takeFileName dir == ghcSandboxPkgDbDir of + True -> dir + False -> takeDirectory dir ghcSandboxPkgDbDir + +-- | Extract the sandbox package db directory from the cabal.sandbox.config +-- file. Exception is thrown if the sandbox config file is broken. +extractSandboxDbDir :: String -> Maybe FilePath +extractSandboxDbDir conf = extractValue <$> parse conf + where + key = "package-db:" + keyLen = length key + + parse = listToMaybe . filter (key `isPrefixOf`) . lines + extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen + + -- | -- >>> isCabalFile "/home/user/.cabal" -- False @@ -117,7 +144,7 @@ findCabalSandboxDir dir = do _ -> Nothing where - isSandboxConfig = (=="cabal.sandbox.config") + isSandboxConfig = (==sandboConfigFile) zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)] zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as @@ -150,34 +177,12 @@ parents dir' = ---------------------------------------------------------------- --- | Get path to sandbox config file -getSandboxDb :: FilePath -- ^ Path to the cabal package root directory - -- (containing the @cabal.sandbox.config@ file) - -> IO (Maybe GhcPkgDb) -getSandboxDb d = do - mConf <- traverse readFile =<< U.mightExist (d "cabal.sandbox.config") - return $ PackageDb . fixPkgDbVer <$> (extractSandboxDbDir =<< mConf) - - where - fixPkgDbVer dir = - case takeFileName dir == ghcSandboxPkgDbDir of - True -> dir - False -> takeDirectory dir ghcSandboxPkgDbDir - --- | Extract the sandbox package db directory from the cabal.sandbox.config file. --- Exception is thrown if the sandbox config file is broken. -extractSandboxDbDir :: String -> Maybe FilePath -extractSandboxDbDir conf = extractValue <$> parse conf - where - key = "package-db:" - keyLen = length key - - parse = listToMaybe . filter (key `isPrefixOf`) . lines - extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen - setupConfigFile :: Cradle -> FilePath setupConfigFile crdl = cradleRootDir crdl setupConfigPath +sandboConfigFile :: FilePath +sandboConfigFile = "cabal.sandbox.config" + -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ setupConfigPath :: FilePath setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref @@ -211,9 +216,12 @@ cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-components" mergedPkgOptsCacheFile :: String mergedPkgOptsCacheFile = setupConfigPath <.> "ghc-mod.package-options" --- | @findCradleFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@. +pkgDbStackCacheFile :: String +pkgDbStackCacheFile = setupConfigPath <.> "ghc-mod.package-db-stack" + +-- | @findCustomPackageDbFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@. -- If it exists in the given directory it is returned otherwise @findCradleFile@ returns @Nothing@ -findCradleFile :: FilePath -> IO (Maybe FilePath) -findCradleFile directory = do - let path = directory "ghc-mod.cradle" +findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath) +findCustomPackageDbFile directory = do + let path = directory "ghc-mod.package-db-stack" mightExist path diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs index a83141f..ddc4a06 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ b/Language/Haskell/GhcMod/PkgDoc.hs @@ -4,6 +4,7 @@ import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Utils +import Language.Haskell.GhcMod.CabalHelper import Control.Applicative import Prelude @@ -11,17 +12,17 @@ import Prelude -- | Obtaining the package name and the doc path of a module. pkgDoc :: IOish m => String -> GhcModT m String pkgDoc mdl = do - c <- cradle - pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts c) "" + pkgDbStack <- getPackageDbStack + pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts pkgDbStack) "" if pkg == "" then return "\n" else do - htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg c) "" + htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg pkgDbStack) "" let ret = pkg ++ " " ++ drop 14 htmlpath return ret where - toModuleOpts c = ["find-module", mdl, "--simple-output"] - ++ ghcPkgDbStackOpts (cradlePkgDbStack c) - toDocDirOpts pkg c = ["field", pkg, "haddock-html"] - ++ ghcPkgDbStackOpts (cradlePkgDbStack c) + toModuleOpts dbs = ["find-module", mdl, "--simple-output"] + ++ ghcPkgDbStackOpts dbs + toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"] + ++ ghcPkgDbStackOpts dbs trim = takeWhile (`notElem` " \n") diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 93afccc..36ed391 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -37,7 +37,7 @@ import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils +import Language.Haskell.GhcMod.Utils as U import Data.Maybe @@ -289,13 +289,21 @@ packageGhcOptions = do Just _ -> getGhcMergedPkgOptions Nothing -> sandboxOpts crdl -sandboxOpts :: Monad m => Cradle -> m [String] -sandboxOpts crdl = +sandboxOpts :: MonadIO m => Cradle -> m [String] +sandboxOpts crdl = do + pkgDbStack <- liftIO $ getSandboxPackageDbStack $ cradleRootDir crdl + let pkgOpts = ghcDbStackOpts pkgDbStack return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"] where - pkgOpts = ghcDbStackOpts $ cradlePkgDbStack crdl (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl) + getSandboxPackageDbStack :: FilePath + -- ^ Project Directory (where the cabal.sandbox.config + -- file would be if it exists) + -> IO [GhcPkgDb] + getSandboxPackageDbStack cdir = + ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir + resolveGmComponent :: (IOish m, GmLog m, GmEnv m) => Maybe [CompilationUnit] -- ^ Updated modules -> GmComponent 'GMCRaw (Set ModulePath) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 1fb7230..f7e0799 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -112,14 +112,17 @@ data Cradle = Cradle { , cradleTempDir :: FilePath -- | The file name of the found cabal file. , cradleCabalFile :: Maybe FilePath - -- | Package database stack - , cradlePkgDbStack :: [GhcPkgDb] } deriving (Eq, Show) ---------------------------------------------------------------- -- | GHC package database flags. -data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show) +data GhcPkgDb = GlobalDb + | UserDb + | PackageDb String + deriving (Eq, Show, Generic) + +instance Serialize GhcPkgDb -- | A single GHC command line option. type GHCOption = String diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs index c9d6b49..e887990 100644 --- a/Language/Haskell/GhcMod/World.hs +++ b/Language/Haskell/GhcMod/World.hs @@ -3,6 +3,7 @@ module Language.Haskell.GhcMod.World where import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Utils import Control.Applicative @@ -20,18 +21,19 @@ data World = World { , worldSymbolCache :: Maybe TimedFile } deriving (Eq, Show) -timedPackageCaches :: Cradle -> IO [TimedFile] -timedPackageCaches crdl = do - fs <- mapM mightExist . map ( packageCache) - =<< getPackageCachePaths libdir crdl - timeFile `mapM` catMaybes fs +timedPackageCaches :: IOish m => GhcModT m [TimedFile] +timedPackageCaches = do + fs <- mapM (liftIO . mightExist) . map ( packageCache) + =<< getPackageCachePaths libdir + (liftIO . timeFile) `mapM` catMaybes fs -getCurrentWorld :: Cradle -> IO World -getCurrentWorld crdl = do - pkgCaches <- timedPackageCaches crdl - mCabalFile <- timeFile `traverse` cradleCabalFile crdl - mCabalConfig <- timeMaybe (setupConfigFile crdl) - mSymbolCache <- timeMaybe (symbolCache crdl) +getCurrentWorld :: IOish m => GhcModT m World +getCurrentWorld = do + crdl <- cradle + pkgCaches <- timedPackageCaches + mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl + mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) + mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl) return World { worldPackageCaches = pkgCaches @@ -40,26 +42,9 @@ getCurrentWorld crdl = do , worldSymbolCache = mSymbolCache } -didWorldChange :: World -> Cradle -> IO Bool -didWorldChange world crdl = do - (world /=) <$> getCurrentWorld crdl - --- * Neither file exists -> should return False: --- @Nothing < Nothing = False@ --- (since we don't need to @cabal configure@ when no cabal file exists.) --- --- * Cabal file doesn't exist (unlikely case) -> should return False --- @Just cc < Nothing = False@ --- TODO: should we delete dist/setup-config? --- --- * dist/setup-config doesn't exist yet -> should return True: --- @Nothing < Just cf = True@ --- --- * Both files exist --- @Just cc < Just cf = cc < cf = cc `olderThan` cf@ -isSetupConfigOutOfDate :: World -> Bool -isSetupConfigOutOfDate World {..} = do - worldCabalConfig < worldCabalFile +didWorldChange :: IOish m => World -> GhcModT m Bool +didWorldChange world = do + (world /=) <$> getCurrentWorld isYoungerThanSetupConfig :: FilePath -> World -> IO Bool isYoungerThanSetupConfig file World {..} = do diff --git a/ghc-mod.cabal b/ghc-mod.cabal index ace73ba..9245a83 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -73,6 +73,11 @@ Extra-Source-Files: ChangeLog test/data/template-haskell/*.hs test/data/target/*.hs test/data/check-missing-warnings/*.hs + test/data/custom-cradle/custom-cradle.cabal + test/data/custom-cradle/ghc-mod.package-db-stack + test/data/custom-cradle/package-db-a/.gitkeep + test/data/custom-cradle/package-db-b/.gitkeep + test/data/custom-cradle/package-db-c/.gitkeep Library Default-Language: Haskell2010 @@ -123,7 +128,7 @@ Library , bytestring , cereal >= 0.4 , containers - , cabal-helper >= 0.3.7.0 + , cabal-helper == 0.3.* && >= 0.3.8.0 , deepseq , directory , filepath diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 43a2e8a..0c8d53d 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -344,7 +344,7 @@ legacyInteractive :: IOish m => GhcModT m () legacyInteractive = do opt <- options symdbreq <- liftIO $ newSymDbReq opt - world <- liftIO . getCurrentWorld =<< cradle + world <- getCurrentWorld legacyInteractiveLoop symdbreq world bug :: String -> IO () @@ -371,7 +371,7 @@ legacyInteractiveLoop symdbreq world = do -- after blocking, we need to see if the world has changed. - changed <- liftIO . didWorldChange world =<< cradle + changed <- didWorldChange world when changed $ do dropSession diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs index 6acdde3..ec6d35e 100644 --- a/test/CabalHelperSpec.hs +++ b/test/CabalHelperSpec.hs @@ -9,7 +9,7 @@ import Language.Haskell.GhcMod.Error import Test.Hspec import System.Directory import System.FilePath -import System.Process (readProcess) +import System.Process (readProcess, system) import Dir import TestUtils @@ -51,8 +51,6 @@ spec = do -- comment in cabal-helper opts <- map gmcGhcOpts . filter ((/= ChSetupHsName) . gmcName) <$> runD' tdir getComponents - print opts - if ghcVersion < 706 then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) else forM_ opts (\o -> o `shouldContain` ["-no-user-package-db","-package-db",cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) @@ -73,3 +71,25 @@ spec = do let ghcOpts = head opts pkgs = pkgOptions ghcOpts pkgs `shouldBe` ["Cabal","base"] + + describe "getCustomPkgDbStack" $ do + it "works" $ do + let tdir = "test/data/custom-cradle" + Just stack <- runD' tdir $ getCustomPkgDbStack + stack `shouldBe` [ GlobalDb + , UserDb + , PackageDb "package-db-a" + , PackageDb "package-db-b" + , PackageDb "package-db-c" + ] + + describe "getPackageDbStack'" $ do + it "fixes out of sync custom pkg-db stack" $ do + withDirectory_ "test/data/custom-cradle" $ do + _ <- system "cabal configure" + (s, s') <- runD $ do + Just stack <- getCustomPkgDbStack + withCabal $ do + stack' <- getPackageDbStack' + return (stack, stack') + s' `shouldBe` s diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index 97fc81d..360b7e0 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -9,7 +9,6 @@ import System.FilePath (pathSeparator) import Test.Hspec import Dir -import TestUtils clean_ :: IO Cradle -> IO Cradle clean_ f = do @@ -40,10 +39,8 @@ spec = do cradleCurrentDir res `shouldBe` curDir cradleRootDir res `shouldBe` curDir cradleCabalFile res `shouldBe` Nothing - cradlePkgDbStack res `shouldBe` [GlobalDb,UserDb] it "finds a cabal file and a sandbox" $ do - cwd <- getCurrentDirectory withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do res <- relativeCradle dir <$> clean_ findCradle @@ -55,10 +52,6 @@ spec = do cradleCabalFile res `shouldBe` Just ("test/data/cabal-project/cabalapi.cabal") - let [GlobalDb, sb] = cradlePkgDbStack res - sb `shouldSatisfy` - isPkgDbAt (cwd "test/data/cabal-project/.cabal-sandbox") - it "works even if a sandbox config file is broken" $ do withDirectory "test/data/broken-sandbox" $ \dir -> do res <- relativeCradle dir <$> clean_ findCradle @@ -70,13 +63,3 @@ spec = do cradleCabalFile res `shouldBe` Just ("test" "data" "broken-sandbox" "dummy.cabal") - - cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb] - - it "uses the custom cradle file if present" $ do - withDirectory "test/data/custom-cradle" $ \dir -> do - res <- relativeCradle dir <$> findCradle - cradleCurrentDir res `shouldBe` "test" "data" "custom-cradle" - cradleRootDir res `shouldBe` "test" "data" "custom-cradle" - cradleCabalFile res `shouldBe` Just ("test" "data" "custom-cradle" "dummy.cabal") - cradlePkgDbStack res `shouldBe` [PackageDb "a/packages", GlobalDb, PackageDb "b/packages", UserDb, PackageDb "c/packages"] diff --git a/test/Main.hs b/test/Main.hs index 4422d5a..18aa1eb 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -30,7 +30,10 @@ main = do let caches = [ "setup-config" , "setup-config.ghc-mod.cabal-helper" + , "setup-config.ghc-mod.cabal-components" , "setup-config.ghc-mod.resolved-components" + , "setup-config.ghc-mod.package-options" + , "setup-config.ghc-mod.package-db-stack" , "ghc-mod.cache" ] cachesFindExp :: String diff --git a/test/data/custom-cradle/custom-cradle.cabal b/test/data/custom-cradle/custom-cradle.cabal new file mode 100644 index 0000000..f157254 --- /dev/null +++ b/test/data/custom-cradle/custom-cradle.cabal @@ -0,0 +1,12 @@ +name: custom-cradle +version: 0.1.0.0 +homepage: asd +license-file: LICENSE +author: asd +maintainer: asd +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base >=4.7 && <4.8 + default-language: Haskell2010 \ No newline at end of file diff --git a/test/data/custom-cradle/dummy.cabal b/test/data/custom-cradle/dummy.cabal deleted file mode 100644 index 421376d..0000000 --- a/test/data/custom-cradle/dummy.cabal +++ /dev/null @@ -1 +0,0 @@ -dummy diff --git a/test/data/custom-cradle/ghc-mod.cradle b/test/data/custom-cradle/ghc-mod.cradle deleted file mode 100644 index 38259f1..0000000 --- a/test/data/custom-cradle/ghc-mod.cradle +++ /dev/null @@ -1,5 +0,0 @@ -a/packages -global -b/packages -user -c/packages diff --git a/test/data/custom-cradle/ghc-mod.package-db-stack b/test/data/custom-cradle/ghc-mod.package-db-stack new file mode 100644 index 0000000..ce2d741 --- /dev/null +++ b/test/data/custom-cradle/ghc-mod.package-db-stack @@ -0,0 +1,5 @@ +global +user +package-db-a +package-db-b +package-db-c diff --git a/test/data/custom-cradle/package-db-a/.gitkeep b/test/data/custom-cradle/package-db-a/.gitkeep new file mode 100644 index 0000000..e69de29 diff --git a/test/data/custom-cradle/package-db-b/.gitkeep b/test/data/custom-cradle/package-db-b/.gitkeep new file mode 100644 index 0000000..e69de29 diff --git a/test/data/custom-cradle/package-db-c/.gitkeep b/test/data/custom-cradle/package-db-c/.gitkeep new file mode 100644 index 0000000..e69de29 From 0abe1d6a53a4dc7622fd78bdbec12a7a2c89778b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 7 Aug 2015 07:33:04 +0200 Subject: [PATCH 157/207] Fix warning --- Language/Haskell/GhcMod/FillSig.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 246baaa..1f65f93 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -356,8 +356,8 @@ refine file lineNo colNo (Expression expr) = diffArgs' = length eArgs - length rArgs diffArgs = if diffArgs' < 0 then 0 else diffArgs' iArgs = take diffArgs eArgs - text = initialHead1 expr iArgs (infinitePrefixSupply name) - in (fourInts loc, doParen paren text) + txt = initialHead1 expr iArgs (infinitePrefixSupply name) + in (fourInts loc, doParen paren txt) where handler (SomeException ex) = do gmLog GmDebug "refining" $ From 5b30fdde2974b1f6df0e864df839564d0135e5c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 10 Aug 2015 03:57:47 +0200 Subject: [PATCH 158/207] Remove version bounds from test cabal files --- test/data/cabal-flags/cabal-flags.cabal | 3 +-- test/data/cabal-project/cabalapi.cabal | 4 ++-- test/data/custom-cradle/custom-cradle.cabal | 2 +- test/data/ghc-mod-check/ghc-mod-check.cabal | 2 +- 4 files changed, 5 insertions(+), 6 deletions(-) diff --git a/test/data/cabal-flags/cabal-flags.cabal b/test/data/cabal-flags/cabal-flags.cabal index d133d5b..f94cb70 100644 --- a/test/data/cabal-flags/cabal-flags.cabal +++ b/test/data/cabal-flags/cabal-flags.cabal @@ -7,8 +7,7 @@ flag test-flag default: False library - build-depends: base == 4.* + build-depends: base if flag(test-flag) build-depends: Cabal >= 1.10 - diff --git a/test/data/cabal-project/cabalapi.cabal b/test/data/cabal-project/cabalapi.cabal index 443a25e..882ed03 100644 --- a/test/data/cabal-project/cabalapi.cabal +++ b/test/data/cabal-project/cabalapi.cabal @@ -44,7 +44,7 @@ Executable ghc-mod Paths_ghc_mod Types GHC-Options: -Wall - Build-Depends: base >= 4.0 && < 5 + Build-Depends: base , Cabal >= 1.10 , template-haskell @@ -59,7 +59,7 @@ Test-Suite spec LangSpec LintSpec ListSpec - Build-Depends: base >= 4.0 && < 5 + Build-Depends: base , Cabal >= 1.10 Source-Repository head diff --git a/test/data/custom-cradle/custom-cradle.cabal b/test/data/custom-cradle/custom-cradle.cabal index f157254..9ccb91b 100644 --- a/test/data/custom-cradle/custom-cradle.cabal +++ b/test/data/custom-cradle/custom-cradle.cabal @@ -8,5 +8,5 @@ build-type: Simple cabal-version: >=1.10 library - build-depends: base >=4.7 && <4.8 + build-depends: base default-language: Haskell2010 \ No newline at end of file diff --git a/test/data/ghc-mod-check/ghc-mod-check.cabal b/test/data/ghc-mod-check/ghc-mod-check.cabal index 1b82a13..3f472e5 100644 --- a/test/data/ghc-mod-check/ghc-mod-check.cabal +++ b/test/data/ghc-mod-check/ghc-mod-check.cabal @@ -22,5 +22,5 @@ library executable foo Main-Is: main.hs GHC-Options: -Wall - Build-Depends: base >= 4 && < 5 + Build-Depends: base , ghc-mod-check From c71528c574969ec4a649b86cf71049e372f708af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 10 Aug 2015 04:28:43 +0200 Subject: [PATCH 159/207] Don't look for ghc-modi in ghc-debug, fix #526 --- elisp/ghc.el | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/elisp/ghc.el b/elisp/ghc.el index 199d11a..011636e 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -133,20 +133,17 @@ (let ((el-path (locate-file "ghc.el" load-path)) (ghc-path (executable-find "ghc")) ;; FIXME (ghc-mod-path (executable-find ghc-module-command)) - (ghc-modi-path (executable-find ghc-interactive-command)) (el-ver ghc-version) (ghc-ver (ghc-run-ghc-mod '("--version") "ghc")) (ghc-mod-ver (ghc-run-ghc-mod '("version"))) - (ghc-modi-ver (ghc-run-ghc-mod '("version") ghc-interactive-command)) (path (getenv "PATH"))) (switch-to-buffer (get-buffer-create "**GHC Debug**")) (erase-buffer) (insert "Path: check if you are using intended programs.\n") (insert (format "\t ghc.el path: %s\n" el-path)) (insert (format "\t ghc-mod path: %s\n" ghc-mod-path)) - (insert (format "\tghc-modi path: %s\n" ghc-modi-path)) (insert (format "\t ghc path: %s\n" ghc-path)) - (insert "\nVersion: all versions must be the same.\n") + (insert "\nVersion: all GHC versions must be the same.\n") (insert (format "\t ghc.el version %s\n" el-ver)) (insert (format "\t %s\n" ghc-mod-ver)) (insert (format "\t%s\n" ghc-modi-ver)) From bb22b643e9d8bc5d56749e8f2f1a9912cd62cb8c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 10 Aug 2015 05:00:58 +0200 Subject: [PATCH 160/207] Add version header to caches --- Language/Haskell/GhcMod/Caching.hs | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs index 5de2ff1..195c580 100644 --- a/Language/Haskell/GhcMod/Caching.hs +++ b/Language/Haskell/GhcMod/Caching.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} module Language.Haskell.GhcMod.Caching where +import Control.Arrow (first) import Control.Monad.Trans.Maybe import Data.Maybe import Data.Serialize +import Data.Version import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 import System.FilePath import Utils (TimedFile(..), timeMaybe, mightExist) +import Paths_ghc_mod (version) import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Logging @@ -63,7 +68,7 @@ cached dir cd d = do tcfile <- liftIO $ timeMaybe (cacheFile cd) case mcc of Nothing -> - writeCache (TimedCacheFiles tcfile []) Nothing "cache missing" + writeCache (TimedCacheFiles tcfile []) Nothing "cache missing or unreadable" Just (ifs, d', a) | d /= d' -> do tcf <- timeCacheInput dir (cacheFile cd) ifs writeCache tcf (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d' @@ -75,11 +80,14 @@ cached dir cd d = do Nothing -> writeCache tcf (Just a) "cache missing, existed a sec ago WTF?" where + cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n" + writeCache tcf ma cause = do (ifs', a) <- (cachedAction cd) tcf d ma gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) <+> parens (text cause) - liftIO $ BS.writeFile (dir cacheFile cd) $ encode (ifs', d, a) + liftIO $ BS.writeFile (dir cacheFile cd) $ + BS.append cacheHeader $ encode (ifs', d, a) return a readCache :: m (Maybe ([FilePath], d, a)) @@ -90,7 +98,11 @@ cached dir cd d = do readCache' f = do gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd) cc <- liftIO $ BS.readFile f - return $ either (const Nothing) Just $ decode cc + case first BS8.words $ BS8.span (/='\n') cc of + (["Written", "by", "ghc-mod", ver], rest) + | BS8.unpack ver == showVersion version -> + return $ either (const Nothing) Just $ decode $ BS.drop 1 rest + _ -> return Nothing timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles timeCacheInput dir cfile ifs = liftIO $ do From c4d534ba1c4f7907f0d296c814355f17ac08f413 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 10 Aug 2015 05:14:31 +0200 Subject: [PATCH 161/207] Make sure preprocessed module are on the module path --- ghc-mod.cabal | 3 +++ test/CheckSpec.hs | 7 +++++++ test/data/cabal-preprocessors/Main.hs | 4 ++++ test/data/cabal-preprocessors/Preprocessed.hsc | 3 +++ .../cabal-preprocessors/cabal-preprocessors.cabal | 14 ++++++++++++++ 5 files changed, 31 insertions(+) create mode 100644 test/data/cabal-preprocessors/Main.hs create mode 100644 test/data/cabal-preprocessors/Preprocessed.hsc create mode 100644 test/data/cabal-preprocessors/cabal-preprocessors.cabal diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 9245a83..f773c7b 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -78,6 +78,9 @@ Extra-Source-Files: ChangeLog test/data/custom-cradle/package-db-a/.gitkeep test/data/custom-cradle/package-db-b/.gitkeep test/data/custom-cradle/package-db-c/.gitkeep + test/data/cabal-preprocessors/*.cabal + test/data/cabal-preprocessors/*.hs + test/data/cabal-preprocessors/*.hsc Library Default-Language: Haskell2010 diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index 7eaa4d8..1893e0c 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -57,3 +57,10 @@ spec = do withDirectory_ "test/data/check-missing-warnings" $ do res <- runD $ checkSyntax ["DesugarWarnings.hs"] res `shouldBe` "DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched: _ : _\n" + + it "works with cabal builtin preprocessors" $ do + withDirectory_ "test/data/cabal-preprocessors" $ do + _ <- system "cabal clean" + _ <- system "cabal build" + res <- runD $ checkSyntax ["Main.hs"] + res `shouldBe` "Preprocessed.hsc:3:1:Warning: Top-level binding with no type signature: warning :: ()\n" diff --git a/test/data/cabal-preprocessors/Main.hs b/test/data/cabal-preprocessors/Main.hs new file mode 100644 index 0000000..dbd74c3 --- /dev/null +++ b/test/data/cabal-preprocessors/Main.hs @@ -0,0 +1,4 @@ +import Preprocessed + +main :: IO () +main = return warning diff --git a/test/data/cabal-preprocessors/Preprocessed.hsc b/test/data/cabal-preprocessors/Preprocessed.hsc new file mode 100644 index 0000000..8e34f94 --- /dev/null +++ b/test/data/cabal-preprocessors/Preprocessed.hsc @@ -0,0 +1,3 @@ +module Preprocessed where + +warning = () diff --git a/test/data/cabal-preprocessors/cabal-preprocessors.cabal b/test/data/cabal-preprocessors/cabal-preprocessors.cabal new file mode 100644 index 0000000..d0a5039 --- /dev/null +++ b/test/data/cabal-preprocessors/cabal-preprocessors.cabal @@ -0,0 +1,14 @@ +name: cabal-preprocessors +version: 0.1.0.0 +license-file: LICENSE +author: asd +maintainer: asd +build-type: Simple +cabal-version: >=1.10 + +executable cabal-preprocessors + main-is: Main.hs + build-depends: base + default-language: Haskell2010 + other-modules: Preprocessed + ghc-options: -Wall \ No newline at end of file From 369b5c5d6e2aa288ba27179247d870afc1c060d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 10 Aug 2015 08:02:52 +0200 Subject: [PATCH 162/207] Bump cabal-helper dependency --- ghc-mod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index f773c7b..07f44e0 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -131,7 +131,7 @@ Library , bytestring , cereal >= 0.4 , containers - , cabal-helper == 0.3.* && >= 0.3.8.0 + , cabal-helper == 0.3.* && >= 0.3.9.0 , deepseq , directory , filepath From 36c42531355ef273214f61a7fadbf40137c5b2db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 10 Aug 2015 08:15:34 +0200 Subject: [PATCH 163/207] Desugar warnings don't work before ghc 7.8 --- test/CheckSpec.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index 1893e0c..cc9b219 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -53,10 +53,13 @@ spec = do res <- runD $ checkSyntax ["Foo.hs"] res `shouldBe` "" +#if __GLASGOW_HASKELL__ >= 708 +-- See https://github.com/kazu-yamamoto/ghc-mod/issues/507 it "emits warnings generated in GHC's desugar stage" $ do withDirectory_ "test/data/check-missing-warnings" $ do res <- runD $ checkSyntax ["DesugarWarnings.hs"] res `shouldBe` "DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched: _ : _\n" +#endif it "works with cabal builtin preprocessors" $ do withDirectory_ "test/data/cabal-preprocessors" $ do From bad431a7581694398686cea6b2b3f95a2044ae8e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 10 Aug 2015 09:07:41 +0200 Subject: [PATCH 164/207] Bump cabal-helper depdendency --- Language/Haskell/GhcMod/CabalHelper.hs | 20 +++++++++++--------- ghc-mod.cabal | 2 +- 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 9c0ad95..b53f5a5 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -50,8 +50,8 @@ getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmLog m) => m [GHCOption] getGhcMergedPkgOptions = chCached Cached { cacheFile = mergedPkgOptsCacheFile, - cachedAction = \ _tcf (progs, root, _) _ma -> do - opts <- withCabal $ runQuery' progs root $ ghcMergedPkgOptions + cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do + opts <- withCabal $ runQuery' progs rootdir distdir $ ghcMergedPkgOptions return ([setupConfigPath], opts) } @@ -75,8 +75,8 @@ getPackageDbStack = do getPackageDbStack' :: (IOish m, GmEnv m, GmLog m) => m [GhcPkgDb] getPackageDbStack' = chCached Cached { cacheFile = pkgDbStackCacheFile, - cachedAction = \ _tcf (progs, root, _) _ma -> do - dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery' progs root packageDbStack + cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do + dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery' progs rootdir distdir packageDbStack return ([setupConfigPath, sandboConfigFile], dbs) } @@ -96,11 +96,11 @@ getComponents = chCached cabalHelperCache cabalHelperCache :: (Functor m, Applicative m, MonadIO m) - => Cached m (Programs, FilePath, (Version, String)) [GmComponent 'GMCRaw ChEntrypoint] + => Cached m (Programs, FilePath, FilePath, (Version, String)) [GmComponent 'GMCRaw ChEntrypoint] cabalHelperCache = Cached { cacheFile = cabalHelperCacheFile, - cachedAction = \ _tcf (progs, root, _vers) _ma -> - runQuery' progs root $ do + cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma -> + runQuery' progs rootdir distdir $ do q <- join7 <$> ghcOptions <*> ghcPkgOptions @@ -135,7 +135,8 @@ withCabal action = do pkgDbStackOutOfSync <- case mCusPkgDbStack of Just cusPkgDbStack -> do - pkgDb <- runQuery' (helperProgs opts) (cradleRootDir crdl "dist") $ + let root = cradleRootDir crdl + pkgDb <- runQuery' (helperProgs opts) root (root "dist") $ map chPkgToGhcPkg <$> packageDbStack return $ pkgDb /= cusPkgDbStack @@ -194,7 +195,7 @@ helperProgs opts = Programs { } chCached :: (Applicative m, IOish m, GmEnv m, GmLog m, Serialize a) - => Cached m (Programs, FilePath, (Version, [Char])) a -> m a + => Cached m (Programs, FilePath, FilePath, (Version, [Char])) a -> m a chCached c = do root <- cradleRootDir <$> cradle d <- cacheInputData root @@ -203,6 +204,7 @@ chCached c = do cacheInputData root = do opt <- options return $ ( helperProgs opt + , root , root "dist" , (gmVer, chVer) ) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 07f44e0..7ae5944 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -131,7 +131,7 @@ Library , bytestring , cereal >= 0.4 , containers - , cabal-helper == 0.3.* && >= 0.3.9.0 + , cabal-helper == 0.4.* && >= 0.4.0.0 , deepseq , directory , filepath From d863e90775a87d8fed11e502cfc1d101185dfa26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 10 Aug 2015 10:10:33 +0200 Subject: [PATCH 165/207] Add nuke-caches command --- src/GHCMod.hs | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 0c8d53d..f475a90 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -11,13 +11,16 @@ import Data.Version (showVersion) import Data.List import Data.List.Split import Data.Char (isSpace) +import Data.Maybe import Exception import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal import Paths_ghc_mod import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import qualified System.Console.GetOpt as O -import System.Directory (setCurrentDirectory) +import System.FilePath (()) +import System.Directory (setCurrentDirectory, getAppUserDataDirectory, + removeDirectoryRecursive) import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush) @@ -439,10 +442,9 @@ ghcCommands (cmd:args) = do "dumpsym" -> dumpSymbolCmd "boot" -> bootCmd "legacy-interactive" -> legacyInteractiveCmd + "nuke-caches" -> nukeCachesCmd _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" - - newtype FatalError = FatalError String deriving (Show, Typeable) instance Exception FatalError @@ -482,7 +484,7 @@ catchArgs cmd action = modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd, debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, - dumpSymbolCmd, bootCmd, legacyInteractiveCmd + dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd :: IOish m => [String] -> GhcModT m String modulesCmd = withParseCmd' "modules" s $ \[] -> modules @@ -494,6 +496,7 @@ rootInfoCmd = withParseCmd' "root" [] $ \[] -> rootInfo componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts -- internal bootCmd = withParseCmd' "boot" [] $ \[] -> boot +nukeCachesCmd = withParseCmd' "nuke-caches" [] $ \[] -> nukeCaches >> return "" dumpSymbolCmd = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir findSymbolCmd = withParseCmd' "find" [] $ \[sym] -> findSymbol sym @@ -555,3 +558,16 @@ browseArgSpec = , option "q" ["qualified"] "Qualify symbols" $ NoArg $ \o -> o { qualified = True } ] + +nukeCaches :: IOish m => GhcModT m () +nukeCaches = do + chdir <- liftIO $ ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" + c <- cradle + + when (isJust $ cradleCabalFile c) $ do + let root = cradleRootDir c + when (isJust $ cradleCabalFile c) $ + liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root "dist"] + +trySome :: IO a -> IO (Either SomeException a) +trySome = try From 1542a068f0e1ed4054ae40556b1faa6c1568c25e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 10 Aug 2015 10:10:40 +0200 Subject: [PATCH 166/207] Rename debugComponent -> debug-component --- src/GHCMod.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index f475a90..1853b5e 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -428,7 +428,7 @@ ghcCommands (cmd:args) = do "check" -> checkSyntaxCmd "expand" -> expandTemplateCmd "debug" -> debugInfoCmd - "debugComponent" -> componentInfoCmd + "debug-component" -> componentInfoCmd "info" -> infoCmd "type" -> typesCmd "split" -> splitsCmd From 54dcfdf2919908bd8987290056ea3c9051941fcf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 10 Aug 2015 11:09:11 +0200 Subject: [PATCH 167/207] Defer the inevitable rewrite of the cmdline parser a little while longer anyways --- src/GHCMod.hs | 83 +++++++++++++++++++++++++++++++++------------------ 1 file changed, 54 insertions(+), 29 deletions(-) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 1853b5e..2f11b9f 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -30,10 +30,16 @@ import Prelude import Misc -progVersion :: String -progVersion = - "ghc-mod version " ++ showVersion version ++ " compiled by GHC " - ++ cProjectVersion ++ "\n" +progVersion :: String -> String +progVersion pf = + "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC " + ++ cProjectVersion ++ "\n" + +ghcModVersion :: String +ghcModVersion = progVersion "" + +ghcModiVersion :: String +ghcModiVersion = progVersion "i" optionUsage :: (String -> String) -> [OptDescr a] -> [String] optionUsage indent opts = concatMap optUsage opts @@ -238,43 +244,52 @@ optArg udsc dsc = OptArg dsc udsc intToLogLevel :: Int -> GmLogLevel intToLogLevel = toEnum -globalArgSpec :: [OptDescr (Options -> Options)] +globalArgSpec :: [OptDescr (Options -> Either [String] Options)] globalArgSpec = [ option "v" ["verbose"] "Increase or set log level. (0-7)" $ - optArg "LEVEL" $ \ml o -> o { + optArg "LEVEL" $ \ml o -> Right $ o { logLevel = case ml of Nothing -> increaseLogLevel (logLevel o) Just l -> toEnum $ min 7 $ read l } , option "s" [] "Be silent, set log level to 0" $ - NoArg $ \o -> o { logLevel = toEnum 0 } + NoArg $ \o -> Right $ o { logLevel = toEnum 0 } , option "l" ["tolisp"] "Format output as an S-Expression" $ - NoArg $ \o -> o { outputStyle = LispStyle } + NoArg $ \o -> Right $ o { outputStyle = LispStyle } , option "b" ["boundary"] "Output line separator"$ - reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s } + reqArg "SEP" $ \s o -> Right $ o { lineSeparator = LineSeparator s } , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $ - reqArg "OPT" $ \g o -> + reqArg "OPT" $ \g o -> Right $ o { ghcUserOptions = g : ghcUserOptions o } , option "" ["with-ghc"] "GHC executable to use" $ - reqArg "PROG" $ \p o -> o { ghcProgram = p } + reqArg "PROG" $ \p o -> Right $ o { ghcProgram = p } , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $ - reqArg "PROG" $ \p o -> o { ghcPkgProgram = p } + reqArg "PROG" $ \p o -> Right $ o { ghcPkgProgram = p } , option "" ["with-cabal"] "cabal-install executable to use" $ - reqArg "PROG" $ \p o -> o { cabalProgram = p } + reqArg "PROG" $ \p o -> Right $ o { cabalProgram = p } + + , option "" ["version"] "print version information" $ + NoArg $ \_ -> Left ["version"] + + , option "" ["help"] "print this help message" $ + NoArg $ \_ -> Left ["help"] + ] parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String]) parseGlobalArgs argv = case O.getOpt' RequireOrder globalArgSpec argv of - (o,r,u,[]) -> Right $ (foldr id defaultOptions o, u ++ r) + (o,r,u,[]) -> case foldr (=<<) (Right defaultOptions) o of + Right o' -> Right (o', u ++ r) + Left c -> Right (defaultOptions, c) (_,_,u,e) -> Left $ InvalidCommandLine $ Right $ "Parsing command line options failed: " ++ concat (e ++ map errUnrec u) @@ -282,13 +297,15 @@ parseGlobalArgs argv errUnrec :: String -> String errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" -parseCommandArgs :: [OptDescr (Options -> Options)] +parseCommandArgs :: [OptDescr (Options -> Either [String] Options)] -> [String] -> Options -> (Options, [String]) parseCommandArgs spec argv opts = case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of - (o,r,[]) -> (foldr id opts o, r) + (o,r,[]) -> case foldr (=<<) (Right opts) o of + Right o' -> (o', r) + Left c -> (defaultOptions, c) (_,_,errs) -> fatalError $ "Parsing command options failed: " ++ concat errs @@ -411,8 +428,8 @@ legacyInteractiveLoop symdbreq world = do globalCommands :: [String] -> Maybe String globalCommands [] = Nothing globalCommands (cmd:_) = case cmd of - _ | cmd == "help" || cmd == "--help" -> Just usage - _ | cmd == "version" || cmd == "--version" -> Just progVersion + _ | cmd == "help" -> Just usage + _ | cmd == "version" -> Just ghcModVersion _ -> Nothing ghcCommands :: IOish m => [String] -> GhcModT m () @@ -459,7 +476,7 @@ fatalError :: String -> a fatalError s = throw $ FatalError $ "ghc-mod: " ++ s withParseCmd :: IOish m - => [OptDescr (Options -> Options)] + => [OptDescr (Options -> Either [String] Options)] -> ([String] -> GhcModT m a) -> [String] -> GhcModT m a @@ -469,7 +486,7 @@ withParseCmd spec action args = do withParseCmd' :: (IOish m, ExceptionMonad m) => String - -> [OptDescr (Options -> Options)] + -> [OptDescr (Options -> Either [String] Options)] -> ([String] -> GhcModT m a) -> [String] -> GhcModT m a @@ -519,7 +536,15 @@ infoCmd = withParseCmd [] $ action action [file,expr] = info file $ Expression expr action _ = throw $ InvalidCommandLine (Left "info") -legacyInteractiveCmd = withParseCmd [] $ \[] -> legacyInteractive >> return "" +legacyInteractiveCmd = withParseCmd [] go + where + go [] = + legacyInteractive >> return "" + go ("help":[]) = + return usage + go ("version":[]) = + return ghcModiVersion + go _ = throw $ InvalidCommandLine (Left "legacy-interactive") checkAction :: ([t] -> a) -> [t] -> a checkAction _ [] = throw $ InvalidCommandLine (Right "No files given.") @@ -536,27 +561,27 @@ locAction' _ action [f, line,col,expr] = action f (read line) (read col) (Expre locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd) -modulesArgSpec :: [OptDescr (Options -> Options)] +modulesArgSpec :: [OptDescr (Options -> Either [String] Options)] modulesArgSpec = [ option "d" ["detailed"] "Print package modules belong to." $ - NoArg $ \o -> o { detailed = True } + NoArg $ \o -> Right $ o { detailed = True } ] -hlintArgSpec :: [OptDescr (Options -> Options)] +hlintArgSpec :: [OptDescr (Options -> Either [String] Options)] hlintArgSpec = [ option "h" ["hlintOpt"] "Option to be passed to hlint" $ - reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o } + reqArg "hlintOpt" $ \h o -> Right $ o { hlintOpts = h : hlintOpts o } ] -browseArgSpec :: [OptDescr (Options -> Options)] +browseArgSpec :: [OptDescr (Options -> Either [String] Options)] browseArgSpec = [ option "o" ["operators"] "Also print operators." $ - NoArg $ \o -> o { operators = True } + NoArg $ \o -> Right $ o { operators = True } , option "d" ["detailed"] "Print symbols with accompanying signature." $ - NoArg $ \o -> o { detailed = True } + NoArg $ \o -> Right $ o { detailed = True } , option "q" ["qualified"] "Qualify symbols" $ - NoArg $ \o -> o { qualified = True } + NoArg $ \o -> Right $ o { qualified = True } ] nukeCaches :: IOish m => GhcModT m () From 2cd4d6bd8035022db4d35c61e0258f515f4bf39c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 10 Aug 2015 11:10:00 +0200 Subject: [PATCH 168/207] Bind ghc-modi executable to right ghc-mod exe --- ghc-mod.cabal | 5 ++++- src/GHCModi.hs | 41 ++++++++++++++++++++++++++++++++++++++--- 2 files changed, 42 insertions(+), 4 deletions(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 7ae5944..e8be16a 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -184,15 +184,18 @@ Executable ghc-modi Main-Is: GHCModi.hs Other-Modules: Paths_ghc_mod Misc + Utils GHC-Options: -Wall -threaded -fno-warn-deprecations if os(windows) Cpp-Options: -DWINDOWS Default-Extensions: ConstraintKinds, FlexibleContexts - HS-Source-Dirs: src + HS-Source-Dirs: src, . Build-Depends: base >= 4.0 && < 5 , directory , filepath , process + , time + , old-time Test-Suite doctest Type: exitcode-stdio-1.0 diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 3f5c90a..161bc76 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -5,16 +5,51 @@ module Main where +import Control.Applicative +import Control.Monad +import Control.Exception +import Data.Version +import Data.Maybe +import System.IO import System.Exit import System.Process import System.FilePath import System.Environment import Paths_ghc_mod +import Utils +import Prelude main :: IO () main = do + hPutStrLn stderr $ + "Warning: ghc-modi is deprecated please use 'ghc-mod legacy-interactive' instead" + args <- getArgs bindir <- getBinDir - (_, _, _, h) <- - createProcess $ proc (bindir "ghc-mod") $ ["legacy-interactive"] ++ args - exitWith =<< waitForProcess h + let installedExe = bindir "ghc-mod" + mexe <- mplus <$> mightExist installedExe <*> pathExe + case mexe of + Nothing -> do + hPutStrLn stderr $ + "ghc-modi: Could not find '"++installedExe++"', check your installation!" + exitWith $ ExitFailure 1 + + Just exe -> do + (_, _, _, h) <- + createProcess $ proc exe $ ["legacy-interactive"] ++ args + exitWith =<< waitForProcess h + +pathExe :: IO (Maybe String) +pathExe = do + ev <- try $ words <$> readProcess "ghc-mod" ["--version"] "" + let mexe = case ev of + Left (SomeException _) -> Nothing + Right ["ghc-mod", "version", ver + , "compiled", "by", "GHC", _] + | showVersion version == ver -> do + Just "ghc-mod" + Right _ -> Nothing + + when (isNothing mexe) $ + hPutStrLn stderr "ghc-modi: ghc-mod executable on PATH has different version, check your installation!" + return mexe From 05360e0660a05cad462593f301a289f30dea5bf1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 11 Aug 2015 06:35:07 +0200 Subject: [PATCH 169/207] Fix typo --- Language/Haskell/GhcMod/CabalHelper.hs | 2 +- Language/Haskell/GhcMod/PathsAndFiles.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index b53f5a5..57f133d 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -77,7 +77,7 @@ getPackageDbStack' = chCached Cached { cacheFile = pkgDbStackCacheFile, cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery' progs rootdir distdir packageDbStack - return ([setupConfigPath, sandboConfigFile], dbs) + return ([setupConfigPath, sandboxConfigFile], dbs) } chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 527eb21..c344c8f 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -144,7 +144,7 @@ findCabalSandboxDir dir = do _ -> Nothing where - isSandboxConfig = (==sandboConfigFile) + isSandboxConfig = (==sandboxConfigFile) zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)] zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as @@ -180,8 +180,8 @@ parents dir' = setupConfigFile :: Cradle -> FilePath setupConfigFile crdl = cradleRootDir crdl setupConfigPath -sandboConfigFile :: FilePath -sandboConfigFile = "cabal.sandbox.config" +sandboxConfigFile :: FilePath +sandboxConfigFile = "cabal.sandbox.config" -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ setupConfigPath :: FilePath From 11243e53041a8cf0258b11990b892f50fffdab94 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 11 Aug 2015 06:35:14 +0200 Subject: [PATCH 170/207] Add in-memory caching otherwise everything is slow --- Language/Haskell/GhcMod/CabalHelper.hs | 30 ++++---- Language/Haskell/GhcMod/Caching.hs | 97 ++++++++++-------------- Language/Haskell/GhcMod/Caching/Types.hs | 52 +++++++++++++ Language/Haskell/GhcMod/Modules.hs | 2 +- Language/Haskell/GhcMod/Monad/Types.hs | 46 ++--------- Language/Haskell/GhcMod/Target.hs | 11 ++- Language/Haskell/GhcMod/Types.hs | 56 +++++++++++++- ghc-mod.cabal | 6 +- test/doctests.hs | 2 +- 9 files changed, 182 insertions(+), 120 deletions(-) create mode 100644 Language/Haskell/GhcMod/Caching/Types.hs diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 57f133d..ac5bf39 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -26,9 +26,9 @@ module Language.Haskell.GhcMod.CabalHelper import Control.Applicative import Control.Monad +import Control.Category ((.)) import Data.Maybe import Data.Monoid -import Data.Version import Data.Serialize (Serialize) import Data.Traversable import Distribution.Helper @@ -40,15 +40,16 @@ import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Logging import System.FilePath -import Prelude +import Prelude hiding ((.)) import Paths_ghc_mod as GhcMod -- | Only package related GHC options, sufficient for things that don't need to -- access home modules -getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmLog m) - => m [GHCOption] +getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m) + => m [GHCOption] getGhcMergedPkgOptions = chCached Cached { + cacheLens = Just (lGmcMergedPkgOptions . lGmCaches), cacheFile = mergedPkgOptsCacheFile, cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do opts <- withCabal $ runQuery' progs rootdir distdir $ ghcMergedPkgOptions @@ -67,13 +68,14 @@ getCustomPkgDbStack = do mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle return $ parseCustomPackageDb <$> mCusPkgDbFile -getPackageDbStack :: (IOish m, GmEnv m, GmLog m) => m [GhcPkgDb] +getPackageDbStack :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb] getPackageDbStack = do mCusPkgStack <- getCustomPkgDbStack flip fromMaybe mCusPkgStack <$> getPackageDbStack' -getPackageDbStack' :: (IOish m, GmEnv m, GmLog m) => m [GhcPkgDb] +getPackageDbStack' :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb] getPackageDbStack' = chCached Cached { + cacheLens = Just (lGmcPackageDbStack . lGmCaches), cacheFile = pkgDbStackCacheFile, cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery' progs rootdir distdir packageDbStack @@ -90,14 +92,10 @@ chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f -- -- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by -- 'resolveGmComponents'. -getComponents :: (Applicative m, IOish m, GmEnv m, GmLog m) +getComponents :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m) => m [GmComponent 'GMCRaw ChEntrypoint] -getComponents = chCached cabalHelperCache - -cabalHelperCache - :: (Functor m, Applicative m, MonadIO m) - => Cached m (Programs, FilePath, FilePath, (Version, String)) [GmComponent 'GMCRaw ChEntrypoint] -cabalHelperCache = Cached { +getComponents = chCached Cached { + cacheLens = Just (lGmcComponents . lGmCaches), cacheFile = cabalHelperCacheFile, cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma -> runQuery' progs rootdir distdir $ do @@ -144,6 +142,8 @@ withCabal action = do cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack + --TODO: also invalidate when sandboxConfig file changed + when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $ gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project." when pkgDbStackOutOfSync $ @@ -194,8 +194,8 @@ helperProgs opts = Programs { ghcPkgProgram = T.ghcPkgProgram opts } -chCached :: (Applicative m, IOish m, GmEnv m, GmLog m, Serialize a) - => Cached m (Programs, FilePath, FilePath, (Version, [Char])) a -> m a +chCached :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m, Serialize a) + => Cached m GhcModState ChCacheData a -> m a chCached c = do root <- cradleRootDir <$> cradle d <- cacheInputData root diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs index 195c580..2c0219f 100644 --- a/Language/Haskell/GhcMod/Caching.hs +++ b/Language/Haskell/GhcMod/Caching.hs @@ -1,11 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} -module Language.Haskell.GhcMod.Caching where +module Language.Haskell.GhcMod.Caching ( + module Language.Haskell.GhcMod.Caching + , module Language.Haskell.GhcMod.Caching.Types + ) where import Control.Arrow (first) +import Control.Monad import Control.Monad.Trans.Maybe import Data.Maybe -import Data.Serialize +import Data.Serialize (Serialize, encode, decode) import Data.Version +import Data.Label import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import System.FilePath @@ -13,54 +18,13 @@ import Utils (TimedFile(..), timeMaybe, mightExist) import Paths_ghc_mod (version) import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Caching.Types import Language.Haskell.GhcMod.Logging -data Cached m d a = Cached { - cacheFile :: FilePath, - - - cachedAction :: TimedCacheFiles - -> d - -> Maybe a - -> m ([FilePath], a) - - -- ^ @cachedAction tcf data ma@ - -- - -- * @tcf@: Input file timestamps. Not technically necessary, just an - -- optimizazion when knowing which input files changed can make updating the - -- cache faster - -- - -- * @data@: Arbitrary static input data to cache action. Can be used to - -- invalidate the cache using something other than file timestamps - -- i.e. environment tool version numbers - -- - -- * @ma@: Cached data if it existed - -- - -- Returns: - -- - -- * @fst@: Input files used in generating the cache - -- - -- * @snd@: Cache data, will be stored alongside the static input data in the - -- 'cacheFile' - -- - -- The cached action, will only run if one of the following is true: - -- - -- * 'cacheFile' doesn\'t exist yet - -- * 'cacheFile' exists and 'inputData' changed - -- * any files returned by the cached action changed - } - -data TimedCacheFiles = TimedCacheFiles { - tcCacheFile :: Maybe TimedFile, - -- ^ 'cacheFile' timestamp - tcFiles :: [TimedFile] - -- ^ Timestamped files returned by the cached action - } - -- | Cache a MonadIO action with proper invalidation. -cached :: forall m a d. (MonadIO m, GmLog m, Serialize a, Eq d, Serialize d, Show d) +cached :: forall m a d. (MonadIO m, GmLog m, GmState m, Serialize a, Eq d, Serialize d, Show d) => FilePath -- ^ Directory to prepend to 'cacheFile' - -> Cached m d a -- ^ Cache descriptor + -> Cached m GhcModState d a -- ^ Cache descriptor -> d -> m a cached dir cd d = do @@ -86,23 +50,42 @@ cached dir cd d = do (ifs', a) <- (cachedAction cd) tcf d ma gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) <+> parens (text cause) + case cacheLens cd of + Nothing -> return () + Just label -> do + gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd) + setLabel label $ Just (ifs', d, a) + liftIO $ BS.writeFile (dir cacheFile cd) $ BS.append cacheHeader $ encode (ifs', d, a) return a + setLabel l x = do + s <- gmsGet + gmsPut $ set l x s + readCache :: m (Maybe ([FilePath], d, a)) readCache = runMaybeT $ do - f <- MaybeT $ liftIO $ mightExist $ cacheFile cd - MaybeT $ readCache' f - where - readCache' f = do - gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd) - cc <- liftIO $ BS.readFile f - case first BS8.words $ BS8.span (/='\n') cc of - (["Written", "by", "ghc-mod", ver], rest) - | BS8.unpack ver == showVersion version -> - return $ either (const Nothing) Just $ decode $ BS.drop 1 rest - _ -> return Nothing + case cacheLens cd of + Just label -> do + c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile + setLabel label $ Just c + return c + Nothing -> + readCacheFromFile + + readCacheFromFile = do + f <- MaybeT $ liftIO $ mightExist $ cacheFile cd + readCacheFromFile' f + + readCacheFromFile' f = MaybeT $ do + gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd) + cc <- liftIO $ BS.readFile f + case first BS8.words $ BS8.span (/='\n') cc of + (["Written", "by", "ghc-mod", ver], rest) + | BS8.unpack ver == showVersion version -> + return $ either (const Nothing) Just $ decode $ BS.drop 1 rest + _ -> return Nothing timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles timeCacheInput dir cfile ifs = liftIO $ do diff --git a/Language/Haskell/GhcMod/Caching/Types.hs b/Language/Haskell/GhcMod/Caching/Types.hs new file mode 100644 index 0000000..ae32a7c --- /dev/null +++ b/Language/Haskell/GhcMod/Caching/Types.hs @@ -0,0 +1,52 @@ +module Language.Haskell.GhcMod.Caching.Types where + +import Utils +import Data.Label +import Data.Version +import Distribution.Helper + +type CacheContents d a = Maybe ([FilePath], d, a) +type CacheLens s d a = s :-> CacheContents d a + +data Cached m s d a = Cached { + cacheFile :: FilePath, + cacheLens :: Maybe (CacheLens s d a), + cachedAction :: TimedCacheFiles + -> d + -> Maybe a + -> m ([FilePath], a) + + -- ^ @cachedAction tcf data ma@ + -- + -- * @tcf@: Input file timestamps. Not technically necessary, just an + -- optimizazion when knowing which input files changed can make updating the + -- cache faster + -- + -- * @data@: Arbitrary static input data to cache action. Can be used to + -- invalidate the cache using something other than file timestamps + -- i.e. environment tool version numbers + -- + -- * @ma@: Cached data if it existed + -- + -- Returns: + -- + -- * @fst@: Input files used in generating the cache + -- + -- * @snd@: Cache data, will be stored alongside the static input data in the + -- 'cacheFile' + -- + -- The cached action, will only run if one of the following is true: + -- + -- * 'cacheFile' doesn\'t exist yet + -- * 'cacheFile' exists and 'inputData' changed + -- * any files returned by the cached action changed + } + +data TimedCacheFiles = TimedCacheFiles { + tcCacheFile :: Maybe TimedFile, + -- ^ 'cacheFile' timestamp + tcFiles :: [TimedFile] + -- ^ Timestamped files returned by the cached action + } + +type ChCacheData = (Programs, FilePath, FilePath, (Version, [Char])) diff --git a/Language/Haskell/GhcMod/Modules.hs b/Language/Haskell/GhcMod/Modules.hs index 03c69a8..a5766c6 100644 --- a/Language/Haskell/GhcMod/Modules.hs +++ b/Language/Haskell/GhcMod/Modules.hs @@ -14,7 +14,7 @@ import qualified GHC as G ---------------------------------------------------------------- -- | Listing installed modules. -modules :: (IOish m, GmEnv m, GmLog m) => m String +modules :: (IOish m, GmEnv m, GmState m, GmLog m) => m String modules = do Options { detailed } <- options df <- runGmPkgGhc G.getSessionDynFlags diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index e9343e7..0074ec3 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -30,6 +30,7 @@ module Language.Haskell.GhcMod.Monad.Types ( -- * Environment, state and logging , GhcModEnv(..) , GhcModState(..) + , GhcModCaches(..) , defaultGhcModState , GmGhcSession(..) , GmComponent(..) @@ -78,7 +79,7 @@ import Control.Monad.Reader (ReaderT(..)) import Control.Monad.Error (ErrorT(..), MonadError(..)) import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Trans.Journal (JournalT) -import Control.Monad.Trans.Maybe (MaybeT) +import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Base (MonadBase(..), liftBase) import Control.Monad.Trans.Control @@ -95,51 +96,13 @@ import qualified Control.Monad.IO.Class as MTL import Data.Monoid (Monoid) #endif -import Data.Set (Set) -import Data.Map as Map (Map, empty) import Data.Maybe import Data.Monoid import Data.IORef -import Distribution.Helper -import Text.PrettyPrint (Doc) import Prelude import qualified MonadUtils as GHC (MonadIO(..)) -data GhcModEnv = GhcModEnv { - gmOptions :: Options - , gmCradle :: Cradle - } - -data GhcModLog = GhcModLog { - gmLogLevel :: Maybe GmLogLevel, - gmLogVomitDump :: Last Bool, - gmLogMessages :: [(GmLogLevel, String, Doc)] - } deriving (Show) - -instance Monoid GhcModLog where - mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty - GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' = - GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls') - -data GmGhcSession = GmGhcSession { - gmgsOptions :: ![GHCOption], - gmgsSession :: !(IORef HscEnv) - } - -data GhcModState = GhcModState { - gmGhcSession :: !(Maybe GmGhcSession) - , gmComponents :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) - , gmCompilerMode :: !CompilerMode - } - -defaultGhcModState :: GhcModState -defaultGhcModState = GhcModState Nothing Map.empty Simple - -data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read) - ----------------------------------------------------------------- - -- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT' -- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that -- means you can run (almost) all functions from the GHC API on top of 'GhcModT' @@ -270,6 +233,11 @@ instance Monad m => GmState (GhcModT m) where gmsPut = GhcModT . put gmsState = GhcModT . state +instance GmState m => GmState (MaybeT m) where + gmsGet = MaybeT $ Just `liftM` gmsGet + gmsPut = MaybeT . (Just `liftM`) . gmsPut + gmsState = MaybeT . (Just `liftM`) . gmsState + class Monad m => GmLog m where gmlJournal :: GhcModLog -> m () gmlHistory :: m GhcModLog diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 36ed391..a51e906 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -19,6 +19,7 @@ module Language.Haskell.GhcMod.Target where import Control.Arrow import Control.Applicative +import Control.Category ((.)) import Control.Monad.Reader (runReaderT) import GHC import GHC.Paths (libdir) @@ -53,7 +54,7 @@ import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Distribution.Helper -import Prelude +import Prelude hiding ((.)) import System.Directory import System.FilePath @@ -86,7 +87,7 @@ runLightGhc env action = do renv <- newIORef env flip runReaderT renv $ unLightGhc action -runGmPkgGhc :: (IOish m, GmEnv m, GmLog m) => LightGhc a -> m a +runGmPkgGhc :: (IOish m, GmEnv m, GmState m, GmLog m) => LightGhc a -> m a runGmPkgGhc action = do pkgOpts <- packageGhcOptions withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action @@ -203,10 +204,11 @@ targetGhcOptions crdl sefnmn = do let cn = pickComponent candidates return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs -resolvedComponentsCache :: IOish m => Cached (GhcModT m) +resolvedComponentsCache :: IOish m => Cached (GhcModT m) GhcModState [GmComponent 'GMCRaw (Set.Set ModulePath)] (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) resolvedComponentsCache = Cached { + cacheLens = Just (lGmcResolvedComponents . lGmCaches), cacheFile = resolvedComponentsCacheFile, cachedAction = \tcfs comps ma -> do Cradle {..} <- cradle @@ -282,7 +284,8 @@ findCandidates scns = foldl1 Set.intersection scns pickComponent :: Set ChComponentName -> ChComponentName pickComponent scn = Set.findMin scn -packageGhcOptions :: (Applicative m, IOish m, GmEnv m, GmLog m) => m [GHCOption] +packageGhcOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m) + => m [GHCOption] packageGhcOptions = do crdl <- cradle case cradleCabalFile crdl of diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index f7e0799..02532a2 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, - StandaloneDeriving, DefaultSignatures, FlexibleInstances #-} + StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} module Language.Haskell.GhcMod.Types ( module Language.Haskell.GhcMod.Types @@ -13,6 +13,7 @@ import Control.Monad.Error (Error(..)) import qualified Control.Monad.IO.Class as MTL import Control.Exception (Exception) import Control.Applicative +import Control.Monad import Data.Serialize import Data.Version import Data.List (intercalate) @@ -23,16 +24,22 @@ import qualified Data.Set as Set import Data.Monoid import Data.Maybe import Data.Typeable (Typeable) +import Data.IORef +import Data.Label.Derive import Distribution.Helper import Exception (ExceptionMonad) #if __GLASGOW_HASKELL__ < 708 import qualified MonadUtils as GHC (MonadIO(..)) #endif import GHC (ModuleName, moduleNameString, mkModuleName) +import HscTypes (HscEnv) import PackageConfig (PackageConfig) import GHC.Generics +import Text.PrettyPrint (Doc) import Prelude +import Language.Haskell.GhcMod.Caching.Types + -- | A constraint alias (-XConstraintKinds) to make functions dealing with -- 'GhcModT' somewhat cleaner. -- @@ -114,6 +121,50 @@ data Cradle = Cradle { , cradleCabalFile :: Maybe FilePath } deriving (Eq, Show) +data GhcModEnv = GhcModEnv { + gmOptions :: Options + , gmCradle :: Cradle + } + +data GhcModLog = GhcModLog { + gmLogLevel :: Maybe GmLogLevel, + gmLogVomitDump :: Last Bool, + gmLogMessages :: [(GmLogLevel, String, Doc)] + } deriving (Show) + +instance Monoid GhcModLog where + mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty + GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' = + GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls') + +data GmGhcSession = GmGhcSession { + gmgsOptions :: ![GHCOption], + gmgsSession :: !(IORef HscEnv) + } + +data GhcModCaches = GhcModCaches { + gmcPackageDbStack :: CacheContents ChCacheData [GhcPkgDb] + , gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption] + , gmcComponents :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint] + , gmcResolvedComponents :: CacheContents + [GmComponent 'GMCRaw (Set.Set ModulePath)] + (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) + } + +data GhcModState = GhcModState { + gmGhcSession :: !(Maybe GmGhcSession) + , gmComponents :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) + , gmCompilerMode :: !CompilerMode + , gmCaches :: !GhcModCaches + } + +data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read) + +defaultGhcModState :: GhcModState +defaultGhcModState = + GhcModState n Map.empty Simple (GhcModCaches n n n n) + where n = Nothing + ---------------------------------------------------------------- -- | GHC package database flags. @@ -303,3 +354,6 @@ instance Serialize Programs instance Serialize ChModuleName instance Serialize ChComponentName instance Serialize ChEntrypoint + +mkLabel ''GhcModCaches +mkLabel ''GhcModState diff --git a/ghc-mod.cabal b/ghc-mod.cabal index e8be16a..76d700e 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -87,7 +87,7 @@ Library GHC-Options: -Wall -fno-warn-deprecations Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, ConstraintKinds, FlexibleContexts, - DataKinds, KindSignatures + DataKinds, KindSignatures, TypeOperators Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Internal Other-Modules: Paths_ghc_mod @@ -96,6 +96,7 @@ Library Language.Haskell.GhcMod.Browse Language.Haskell.GhcMod.CabalHelper Language.Haskell.GhcMod.Caching + Language.Haskell.GhcMod.Caching.Types Language.Haskell.GhcMod.CaseSplit Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Convert @@ -154,6 +155,7 @@ Library , haskell-src-exts , text , djinn-ghc >= 0.0.2.2 + , fclabels if impl(ghc < 7.8) Build-Depends: convertible if impl(ghc < 7.5) @@ -213,7 +215,7 @@ Test-Suite spec Default-Language: Haskell2010 Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, ConstraintKinds, FlexibleContexts, - DataKinds, KindSignatures + DataKinds, KindSignatures, TypeOperators Main-Is: Main.hs Hs-Source-Dirs: test, . Ghc-Options: -Wall -fno-warn-deprecations diff --git a/test/doctests.hs b/test/doctests.hs index 08da97b..03d710f 100644 --- a/test/doctests.hs +++ b/test/doctests.hs @@ -9,7 +9,7 @@ main = doctest , "-package", "transformers-" ++ VERSION_transformers , "-package", "mtl-" ++ VERSION_mtl , "-package", "directory-" ++ VERSION_directory - , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures" + , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators" , "-idist/build/autogen/" , "-optP-include" , "-optPdist/build/autogen/cabal_macros.h" From be2b3f0ea74a18b42b6973e76f4c3b3e44405395 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 4 Aug 2015 13:46:38 +0900 Subject: [PATCH 171/207] Revert "Fix typo to set process running status" This reverts commit b52c0a5d767282369f2748c5ec070b802ed8e23c. --- elisp/ghc-process.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 7ecfa34..0519549 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -34,7 +34,7 @@ (if ghc-process-running (error "ghc process already running") (progn - (setq ghc-process-running t) + (when ghc-process-running t) (if hook1 (funcall hook1)) (let* ((cbuf (current-buffer)) (name ghc-process-process-name) From 475b2ea02e7b1784d309ea653672ded6611917e8 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 4 Aug 2015 13:47:39 +0900 Subject: [PATCH 172/207] Revert "don't silently ignore case when ghc process is already running in ghc-with-process" This reverts commit ac31e6edc27e252c984ab4be1df205b09866876f. --- elisp/ghc-process.el | 45 +++++++++++++++++++++----------------------- 1 file changed, 21 insertions(+), 24 deletions(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 0519549..b44416e 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -18,8 +18,7 @@ (defvar-local ghc-process-original-buffer nil) (defvar-local ghc-process-original-file nil) (defvar-local ghc-process-callback nil) -(defvar-local ghc-process-hook nil - "Hook that will be called upon successfull completion of ghc-mod command.") +(defvar-local ghc-process-hook nil) (defvar ghc-command "ghc-mod") @@ -31,28 +30,26 @@ (defun ghc-with-process (cmd callback &optional hook1 hook2) (unless ghc-process-process-name (setq ghc-process-process-name (ghc-get-project-root))) - (if ghc-process-running - (error "ghc process already running") - (progn - (when ghc-process-running t) - (if hook1 (funcall hook1)) - (let* ((cbuf (current-buffer)) - (name ghc-process-process-name) - (buf (get-buffer-create (concat " ghc-mod:" name))) - (file (buffer-file-name)) - (cpro (get-process name))) - (ghc-with-current-buffer buf - (setq ghc-process-original-buffer cbuf) - (setq ghc-process-original-file file) - (setq ghc-process-callback callback) - (setq ghc-process-hook hook2) - (erase-buffer) - (let ((pro (ghc-get-process cpro name buf))) - (process-send-string pro cmd) - (when ghc-debug - (ghc-with-debug-buffer - (insert (format "%% %s" cmd)))) - pro)))))) + (when (and ghc-process-process-name (not ghc-process-running)) + (setq ghc-process-running t) + (if hook1 (funcall hook1)) + (let* ((cbuf (current-buffer)) + (name ghc-process-process-name) + (buf (get-buffer-create (concat " ghc-mod:" name))) + (file (buffer-file-name)) + (cpro (get-process name))) + (ghc-with-current-buffer buf + (setq ghc-process-original-buffer cbuf) + (setq ghc-process-original-file file) + (setq ghc-process-callback callback) + (setq ghc-process-hook hook2) + (erase-buffer) + (let ((pro (ghc-get-process cpro name buf))) + (process-send-string pro cmd) + (when ghc-debug + (ghc-with-debug-buffer + (insert (format "%% %s" cmd)))) + pro))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From de448f8ade149c22f3e4863462733ea5799838e9 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 12 Aug 2015 12:58:47 +0900 Subject: [PATCH 173/207] layout only. --- elisp/ghc-comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el index 2b26a16..2209ca2 100644 --- a/elisp/ghc-comp.el +++ b/elisp/ghc-comp.el @@ -127,7 +127,7 @@ unloaded modules are loaded") (interactive) (if (ghc-should-scroll) (ghc-scroll-completion-buffer) - (ghc-try-complete))) + (ghc-try-complete))) (defun ghc-should-scroll () (let ((window (ghc-completion-window))) From b2767bc4481793c6fa85ef57f8bfe4c3c2dcfb71 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 12 Aug 2015 05:07:58 +0200 Subject: [PATCH 174/207] travis: Use cabal-helper git --- .travis.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.travis.yml b/.travis.yml index 1f784ea..c134ceb 100644 --- a/.travis.yml +++ b/.travis.yml @@ -31,6 +31,9 @@ install: # - ls -lR ~/.ghc # - ls -lR ~/.cabal - cabal install -j --only-dependencies --enable-tests + - git clone --depth=1 https://github.com/DanielG/cabal-helper.git + - cabal install cabal-helper/ + script: - touch ChangeLog # Create ChangeLog if we're not on the release branch From 9b286cc4e153d6a59e26e12a46c73ef97f66f462 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 12 Aug 2015 09:04:09 +0200 Subject: [PATCH 175/207] Fix cabal-helper >= 0.5 --- Language/Haskell/GhcMod/CabalHelper.hs | 9 ++++++--- ghc-mod.cabal | 2 +- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index ac5bf39..e434abb 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -125,6 +125,10 @@ withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a withCabal action = do crdl <- cradle opts <- options + + let projdir = cradleRootDir crdl + distdir = projdir "dist" + mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) @@ -133,8 +137,7 @@ withCabal action = do pkgDbStackOutOfSync <- case mCusPkgDbStack of Just cusPkgDbStack -> do - let root = cradleRootDir crdl - pkgDb <- runQuery' (helperProgs opts) root (root "dist") $ + pkgDb <- runQuery' (helperProgs opts) projdir distdir $ map chPkgToGhcPkg <$> packageDbStack return $ pkgDb /= cusPkgDbStack @@ -161,7 +164,7 @@ withCabal action = do ++ map pkgDbArg cusPkgStack liftIO $ void $ readProcess (T.cabalProgram opts) ("configure":progOpts) "" gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" - liftIO $ writeAutogenFiles $ cradleRootDir crdl "dist" + liftIO $ writeAutogenFiles readProcess projdir distdir action pkgDbArg :: GhcPkgDb -> String diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 76d700e..b935bd0 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -132,7 +132,7 @@ Library , bytestring , cereal >= 0.4 , containers - , cabal-helper == 0.4.* && >= 0.4.0.0 + , cabal-helper == 0.5.* && >= 0.5.0.0 , deepseq , directory , filepath From a94d8977a91ec81bd90c74d523577e740d96a286 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 12 Aug 2015 09:04:35 +0200 Subject: [PATCH 176/207] Fix ghc-modi not working in non-cabal projects --- Language/Haskell/GhcMod/GhcPkg.hs | 12 +++++++++++- Language/Haskell/GhcMod/PathsAndFiles.hs | 20 +++++++++----------- 2 files changed, 20 insertions(+), 12 deletions(-) diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index 4418830..f5ca4b0 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -19,6 +19,7 @@ import Prelude import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.CabalHelper +import Language.Haskell.GhcMod.PathsAndFiles ghcVersion :: Int ghcVersion = read cProjectVersionInt @@ -59,7 +60,16 @@ ghcDbOpt (PackageDb pkgDb) getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath] getPackageCachePaths sysPkgCfg = do - pkgDbStack <- getPackageDbStack + crdl <- cradle + pkgDbStack <- if isJust $ cradleCabalFile crdl + then do + getPackageDbStack + else do + mdb <- liftIO $ getSandboxDb $ cradleRootDir crdl + return $ case mdb of + Just db -> [db] + Nothing -> [GlobalDb, UserDb] + catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack -- TODO: use PkgConfRef diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index c344c8f..085cf52 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -29,7 +29,7 @@ import Data.Traversable hiding (mapM) import Distribution.Helper (buildPlatform) import System.Directory import System.FilePath -import System.IO.Unsafe +import System.Process import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Error @@ -78,13 +78,14 @@ getSandboxDb :: FilePath -> IO (Maybe GhcPkgDb) getSandboxDb d = do mConf <- traverse readFile =<< mightExist (d "cabal.sandbox.config") - return $ PackageDb . fixPkgDbVer <$> (extractSandboxDbDir =<< mConf) + bp <- buildPlatform readProcess + return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf) where - fixPkgDbVer dir = - case takeFileName dir == ghcSandboxPkgDbDir of + fixPkgDbVer bp dir = + case takeFileName dir == ghcSandboxPkgDbDir bp of True -> dir - False -> takeDirectory dir ghcSandboxPkgDbDir + False -> takeDirectory dir ghcSandboxPkgDbDir bp -- | Extract the sandbox package db directory from the cabal.sandbox.config -- file. Exception is thrown if the sandbox config file is broken. @@ -190,12 +191,9 @@ setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref macrosHeaderPath :: FilePath macrosHeaderPath = "dist/build/autogen/cabal_macros.h" -ghcSandboxPkgDbDir :: String -ghcSandboxPkgDbDir = - cabalBuildPlatform ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d" - -cabalBuildPlatform :: String -cabalBuildPlatform = unsafePerformIO $ buildPlatform +ghcSandboxPkgDbDir :: String -> String +ghcSandboxPkgDbDir buildPlatf = do + buildPlatf ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d" packageCache :: String packageCache = "package.cache" From 28f06e035ddf1720091b3a52e4070ee87e8354f8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 12 Aug 2015 09:25:13 +0200 Subject: [PATCH 177/207] Cleanup project type handling --- Language/Haskell/GhcMod.hs | 1 + Language/Haskell/GhcMod/Cradle.hs | 22 +++++++--------------- Language/Haskell/GhcMod/Debug.hs | 6 +++--- Language/Haskell/GhcMod/GhcPkg.hs | 16 ++++++++-------- Language/Haskell/GhcMod/Target.hs | 13 +++++++------ Language/Haskell/GhcMod/Types.hs | 6 +++++- src/GHCMod.hs | 5 ++--- 7 files changed, 33 insertions(+), 36 deletions(-) diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 516ffa2..c4386a1 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -3,6 +3,7 @@ module Language.Haskell.GhcMod ( -- * Cradle Cradle(..) + , ProjectType(..) , findCradle -- * Options , Options(..) diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index 4a23fab..78e041d 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -29,7 +29,7 @@ findCradle = findCradle' =<< getCurrentDirectory findCradle' :: FilePath -> IO Cradle findCradle' dir = run $ do - (customCradle dir `mplus` cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir) + (cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir) where run a = fillTempDir =<< (fromJust <$> runMaybeT a) findSpecCradle :: FilePath -> IO Cradle @@ -53,17 +53,6 @@ fillTempDir crdl = do tmpDir <- liftIO $ newTempDir (cradleRootDir crdl) return crdl { cradleTempDir = tmpDir } -customCradle :: FilePath -> MaybeT IO Cradle -customCradle wdir = do - cabalFile <- MaybeT $ findCabalFile wdir - let cabalDir = takeDirectory cabalFile - return Cradle { - cradleCurrentDir = wdir - , cradleRootDir = cabalDir - , cradleTempDir = error "tmpDir" - , cradleCabalFile = Just cabalFile - } - cabalCradle :: FilePath -> MaybeT IO Cradle cabalCradle wdir = do cabalFile <- MaybeT $ findCabalFile wdir @@ -71,7 +60,8 @@ cabalCradle wdir = do let cabalDir = takeDirectory cabalFile return Cradle { - cradleCurrentDir = wdir + cradleProjectType = CabalProject + , cradleCurrentDir = wdir , cradleRootDir = cabalDir , cradleTempDir = error "tmpDir" , cradleCabalFile = Just cabalFile @@ -81,7 +71,8 @@ sandboxCradle :: FilePath -> MaybeT IO Cradle sandboxCradle wdir = do sbDir <- MaybeT $ findCabalSandboxDir wdir return Cradle { - cradleCurrentDir = wdir + cradleProjectType = SandboxProject + , cradleCurrentDir = wdir , cradleRootDir = sbDir , cradleTempDir = error "tmpDir" , cradleCabalFile = Nothing @@ -90,7 +81,8 @@ sandboxCradle wdir = do plainCradle :: FilePath -> MaybeT IO Cradle plainCradle wdir = do return $ Cradle { - cradleCurrentDir = wdir + cradleProjectType = PlainProject + , cradleCurrentDir = wdir , cradleRootDir = wdir , cradleTempDir = error "tmpDir" , cradleCabalFile = Nothing diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index fb5de2e..42abedb 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -26,9 +26,9 @@ debugInfo = do Cradle {..} <- cradle cabal <- - case cradleCabalFile of - Just _ -> cabalDebug - Nothing -> return [] + case cradleProjectType of + CabalProject -> cabalDebug + _ -> return [] pkgOpts <- packageGhcOptions diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index f5ca4b0..2908c82 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -61,14 +61,14 @@ ghcDbOpt (PackageDb pkgDb) getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath] getPackageCachePaths sysPkgCfg = do crdl <- cradle - pkgDbStack <- if isJust $ cradleCabalFile crdl - then do - getPackageDbStack - else do - mdb <- liftIO $ getSandboxDb $ cradleRootDir crdl - return $ case mdb of - Just db -> [db] - Nothing -> [GlobalDb, UserDb] + pkgDbStack <- case cradleProjectType crdl of + PlainProject -> + return [GlobalDb, UserDb] + SandboxProject -> do + Just db <- liftIO $ getSandboxDb $ cradleRootDir crdl + return $ [GlobalDb, db] + CabalProject -> + getPackageDbStack catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index a51e906..2b9379d 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -176,9 +176,9 @@ targetGhcOptions :: forall m. IOish m targetGhcOptions crdl sefnmn = do when (Set.null sefnmn) $ error "targetGhcOptions: no targets given" - case cradleCabalFile crdl of - Just _ -> cabalOpts crdl - Nothing -> sandboxOpts crdl + case cradleProjectType crdl of + CabalProject -> cabalOpts crdl + _ -> sandboxOpts crdl where zipMap f l = l `zip` (f `map` l) @@ -288,10 +288,11 @@ packageGhcOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m) => m [GHCOption] packageGhcOptions = do crdl <- cradle - case cradleCabalFile crdl of - Just _ -> getGhcMergedPkgOptions - Nothing -> sandboxOpts crdl + case cradleProjectType crdl of + CabalProject -> getGhcMergedPkgOptions + _ -> sandboxOpts crdl +-- also works for plain projects! sandboxOpts :: MonadIO m => Cradle -> m [String] sandboxOpts crdl = do pkgDbStack <- liftIO $ getSandboxPackageDbStack $ cradleRootDir crdl diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 02532a2..9156425 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -109,10 +109,14 @@ defaultOptions = Options { ---------------------------------------------------------------- +data ProjectType = CabalProject | SandboxProject | PlainProject + deriving (Eq, Show) + -- | The environment where this library is used. data Cradle = Cradle { + cradleProjectType:: ProjectType -- | The directory where this library is executed. - cradleCurrentDir :: FilePath + , cradleCurrentDir :: FilePath -- | The project root directory. , cradleRootDir :: FilePath -- | Per-Project temporary directory diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 2f11b9f..a81f938 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -589,10 +589,9 @@ nukeCaches = do chdir <- liftIO $ ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" c <- cradle - when (isJust $ cradleCabalFile c) $ do + when (cradleProjectType c == CabalProject) $ do let root = cradleRootDir c - when (isJust $ cradleCabalFile c) $ - liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root "dist"] + liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root "dist"] trySome :: IO a -> IO (Either SomeException a) trySome = try From 5318db06f74c8dbc6fde0d5c5285dd93873ffa45 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 12 Aug 2015 10:44:36 +0200 Subject: [PATCH 178/207] Fix cabal-helper tests --- test/CabalHelperSpec.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs index ec6d35e..8e4ba64 100644 --- a/test/CabalHelperSpec.hs +++ b/test/CabalHelperSpec.hs @@ -51,9 +51,10 @@ spec = do -- comment in cabal-helper opts <- map gmcGhcOpts . filter ((/= ChSetupHsName) . gmcName) <$> runD' tdir getComponents + bp <- buildPlatform readProcess if ghcVersion < 706 - then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) - else forM_ opts (\o -> o `shouldContain` ["-no-user-package-db","-package-db",cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) + then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp]) + else forM_ opts (\o -> o `shouldContain` ["-no-user-package-db","-package-db",cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp]) it "extracts build dependencies" $ do let tdir = "test/data/cabal-project" From 443650705cc24c9654bcdcc7d4791aa58ac660a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 12 Aug 2015 10:44:41 +0200 Subject: [PATCH 179/207] Fix #532, Use first component in cabal file for dangling modules in cabal projects --- Language/Haskell/GhcMod/Target.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 2b9379d..66bb80f 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -188,6 +188,7 @@ targetGhcOptions crdl sefnmn = do mcs <- cached cradleRootDir resolvedComponentsCache comps let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn + cns = map gmcName comps candidates = findCandidates $ map snd mdlcs let noCandidates = Set.null candidates @@ -195,8 +196,8 @@ targetGhcOptions crdl sefnmn = do if noCandidates && noModuleHasAnyAssignment then do - gmLog GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to guessed GHC options." - sandboxOpts crdl + gmLog GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to picking first component in cabal file." + return $ gmcGhcOpts $ fromJust $ Map.lookup (head cns) mcs else do when noCandidates $ throwError $ GMECabalCompAssignment mdlcs From dc3ce1551243c021b3f600aa3ff5d25e9116e491 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 12 Aug 2015 15:44:16 +0900 Subject: [PATCH 180/207] caching a project root to a local variable. --- elisp/ghc-check.el | 2 +- elisp/ghc-process.el | 47 +++++++++++++++++++++++--------------------- 2 files changed, 26 insertions(+), 23 deletions(-) diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el index 4e7236a..e468504 100644 --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -137,7 +137,7 @@ nil does not display errors/warnings. info infos) (dolist (err errs (nreverse infos)) (when (string-match regex err) - (let* ((file (expand-file-name (match-string 1 err) (ghc-get-project-root))) ;; for Windows + (let* ((file (expand-file-name (match-string 1 err) ghc-process-root)) ;; for Windows (line (string-to-number (match-string 2 err))) (coln (string-to-number (match-string 3 err))) (msg (match-string 4 err)) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index b44416e..d9c0821 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -19,6 +19,7 @@ (defvar-local ghc-process-original-file nil) (defvar-local ghc-process-callback nil) (defvar-local ghc-process-hook nil) +(defvar-local ghc-process-root nil) (defvar ghc-command "ghc-mod") @@ -28,28 +29,30 @@ (ghc-run-ghc-mod '("root"))) (defun ghc-with-process (cmd callback &optional hook1 hook2) - (unless ghc-process-process-name - (setq ghc-process-process-name (ghc-get-project-root))) - (when (and ghc-process-process-name (not ghc-process-running)) - (setq ghc-process-running t) - (if hook1 (funcall hook1)) - (let* ((cbuf (current-buffer)) - (name ghc-process-process-name) - (buf (get-buffer-create (concat " ghc-mod:" name))) - (file (buffer-file-name)) - (cpro (get-process name))) - (ghc-with-current-buffer buf - (setq ghc-process-original-buffer cbuf) - (setq ghc-process-original-file file) - (setq ghc-process-callback callback) - (setq ghc-process-hook hook2) - (erase-buffer) - (let ((pro (ghc-get-process cpro name buf))) - (process-send-string pro cmd) - (when ghc-debug - (ghc-with-debug-buffer - (insert (format "%% %s" cmd)))) - pro))))) + (let ((root (ghc-get-project-root))) + (unless ghc-process-process-name + (setq ghc-process-process-name root)) + (when (and ghc-process-process-name (not ghc-process-running)) + (setq ghc-process-running t) + (if hook1 (funcall hook1)) + (let* ((cbuf (current-buffer)) + (name ghc-process-process-name) + (buf (get-buffer-create (concat " ghc-mod:" name))) + (file (buffer-file-name)) + (cpro (get-process name))) + (ghc-with-current-buffer buf + (setq ghc-process-original-buffer cbuf) + (setq ghc-process-original-file file) + (setq ghc-process-callback callback) + (setq ghc-process-hook hook2) + (setq ghc-process-root root) + (erase-buffer) + (let ((pro (ghc-get-process cpro name buf))) + (process-send-string pro cmd) + (when ghc-debug + (ghc-with-debug-buffer + (insert (format "%% %s" cmd)))) + pro)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 143d17f92556713243613c28115fc0c0a7a140f0 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 12 Aug 2015 15:47:45 +0900 Subject: [PATCH 181/207] removing ghc-modi-ver which is not defined. --- elisp/ghc.el | 1 - 1 file changed, 1 deletion(-) diff --git a/elisp/ghc.el b/elisp/ghc.el index 011636e..e103f4a 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -146,7 +146,6 @@ (insert "\nVersion: all GHC versions must be the same.\n") (insert (format "\t ghc.el version %s\n" el-ver)) (insert (format "\t %s\n" ghc-mod-ver)) - (insert (format "\t%s\n" ghc-modi-ver)) (insert (format "\t%s\n" ghc-ver)) (insert "\nEnvironment variables:\n") (insert (format "\tPATH=%s\n" path)))) From 2806f702d938a588de969b36c27ec90a697f4ab5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 13 Aug 2015 06:47:12 +0200 Subject: [PATCH 182/207] Start implementing line-prefix stuff readProcess wrapper still missing from CabalHelper --- Language/Haskell/GhcMod.hs | 6 ++ Language/Haskell/GhcMod/CabalHelper.hs | 1 + Language/Haskell/GhcMod/Caching.hs | 2 +- Language/Haskell/GhcMod/Logging.hs | 5 +- Language/Haskell/GhcMod/Monad.hs | 21 ++++-- Language/Haskell/GhcMod/Monad/Types.hs | 3 + Language/Haskell/GhcMod/Output.hs | 54 ++++++++++++++++ Language/Haskell/GhcMod/Stderr.hs | 88 ++++++++++++++++++++++++++ Language/Haskell/GhcMod/Target.hs | 4 +- Language/Haskell/GhcMod/Types.hs | 9 +++ ghc-mod.cabal | 2 + src/GHCMod.hs | 63 +++++++++--------- 12 files changed, 218 insertions(+), 40 deletions(-) create mode 100644 Language/Haskell/GhcMod/Output.hs create mode 100644 Language/Haskell/GhcMod/Stderr.hs diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index c4386a1..45d4401 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -56,6 +56,11 @@ module Language.Haskell.GhcMod ( -- * SymbolDb , loadSymbolDb , isOutdated + -- * Output + , gmPutStr + , gmErrStr + , gmPutStrLn + , gmErrStrLn ) where import Language.Haskell.GhcMod.Boot @@ -76,3 +81,4 @@ import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Target +import Language.Haskell.GhcMod.Output diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index e434abb..9193ba8 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -39,6 +39,7 @@ import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Logging +import Language.Haskell.GhcMod.Stderr import System.FilePath import Prelude hiding ((.)) diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs index 2c0219f..d074a17 100644 --- a/Language/Haskell/GhcMod/Caching.hs +++ b/Language/Haskell/GhcMod/Caching.hs @@ -22,7 +22,7 @@ import Language.Haskell.GhcMod.Caching.Types import Language.Haskell.GhcMod.Logging -- | Cache a MonadIO action with proper invalidation. -cached :: forall m a d. (MonadIO m, GmLog m, GmState m, Serialize a, Eq d, Serialize d, Show d) +cached :: forall m a d. (Gm m, MonadIO m, Serialize a, Eq d, Serialize d, Show d) => FilePath -- ^ Directory to prepend to 'cacheFile' -> Cached m GhcModState d a -- ^ Cache descriptor -> d diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 7c1c7fa..a7a1bea 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -39,6 +39,7 @@ import Prelude import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Pretty +import Language.Haskell.GhcMod.Output gmSetLogLevel :: GmLog m => GmLogLevel -> m () gmSetLogLevel level = @@ -64,7 +65,7 @@ decreaseLogLevel l = pred l -- True -- >>> Just GmDebug <= Just GmException -- False -gmLog :: (MonadIO m, GmLog m) => GmLogLevel -> String -> Doc -> m () +gmLog :: (MonadIO m, GmLog m, GmEnv m) => GmLogLevel -> String -> Doc -> m () gmLog level loc' doc = do GhcModLog { gmLogLevel = Just level' } <- gmlHistory @@ -73,7 +74,7 @@ gmLog level loc' doc = do msgDoc = gmLogLevelDoc level <+>: sep [loc, doc] msg = dropWhileEnd isSpace $ gmRenderDoc msgDoc - when (level <= level') $ liftIO $ hPutStrLn stderr msg + when (level <= level') $ gmErrStrLn msg gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)]) diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 0d74b5d..0b392c9 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -35,10 +35,13 @@ import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Target +import Language.Haskell.GhcMod.Stderr import Control.Arrow (first) import Control.Applicative +import Control.Concurrent + import Control.Monad.Reader (runReaderT) import Control.Monad.State.Strict (runStateT) import Control.Monad.Trans.Journal (runJournalT) @@ -58,11 +61,21 @@ withGhcModEnv dir opt f = withCradle dir (withGhcModEnv' opt f) withGhcModEnv' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a withGhcModEnv' opt f crdl = do olddir <- liftIO getCurrentDirectory - gbracket_ (liftIO $ setCurrentDirectory $ cradleRootDir crdl) - (liftIO $ setCurrentDirectory olddir) - (f $ GhcModEnv opt crdl) + c <- liftIO newChan + let outp = case linePrefix opt of + Just _ -> GmOutputChan c + Nothing -> GmOutputStdio + gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opt crdl outp) where - gbracket_ ma mb mc = gbracket ma (const mb) (const mc) + setup c = liftIO $ do + setCurrentDirectory $ cradleRootDir crdl + forkIO $ stdoutGateway c + + teardown olddir tid = liftIO $ do + setCurrentDirectory olddir + killThread tid + + gbracket_ ma mb mc = gbracket ma mb (const mc) -- | Run a @GhcModT m@ computation. runGhcModT :: IOish m diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 0074ec3..5204c35 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -39,6 +39,7 @@ module Language.Haskell.GhcMod.Monad.Types ( , GmLogLevel(..) , GhcModLog(..) , GhcModError(..) + , Gm , GmEnv(..) , GmState(..) , GmLog(..) @@ -198,6 +199,8 @@ class Monad m => GmEnv m where gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-} +type Gm m = (GmEnv m, GmState m, GmLog m) + instance Monad m => GmEnv (GhcModT m) where gmeAsk = GhcModT ask gmeReader = GhcModT . reader diff --git a/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs new file mode 100644 index 0000000..1ca9ee7 --- /dev/null +++ b/Language/Haskell/GhcMod/Output.hs @@ -0,0 +1,54 @@ +module Language.Haskell.GhcMod.Output ( + gmPutStr + , gmErrStr + , gmPutStrLn + , gmErrStrLn + ) where + +import Data.Char +import System.IO +import Control.Monad +import Control.Concurrent + +import Language.Haskell.GhcMod.Types hiding (LineSeparator) +import Language.Haskell.GhcMod.Monad.Types + +withLines :: (String -> String) -> String -> String +withLines f s = let + res = unlines $ map f $ lines s + in + case s of + [] -> res + _ | generalCategory (last s) /= LineSeparator -> + reverse $ drop 1 $ reverse res + _ -> res + +outputFns :: (GmEnv m, MonadIO m') => m (String -> m' (), String -> m' ()) +outputFns = do + GhcModEnv {..} <- gmeAsk + let Options {..} = gmOptions + + let pfx f = withLines f + let (outPfx, errPfx) = case linePrefix of + Nothing -> ( id, id ) + Just (op, ep) -> ( pfx (op++), pfx (ep++) ) + + return $ case gmOutput of + GmOutputStdio -> + (liftIO . putStr . outPfx , liftIO . hPutStr stderr . errPfx) + GmOutputChan c -> + (liftIO . writeChan c . outPfx, liftIO . writeChan c . errPfx) + +gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn + :: (MonadIO m, GmEnv m) => String -> m () + +gmPutStr str = do + putOut <- fst `liftM` outputFns + putOut str + +gmPutStrLn = gmPutStr . (++"\n") +gmErrStrLn = gmErrStr . (++"\n") + +gmErrStr str = do + putErr <- snd `liftM` outputFns + putErr str diff --git a/Language/Haskell/GhcMod/Stderr.hs b/Language/Haskell/GhcMod/Stderr.hs new file mode 100644 index 0000000..198f062 --- /dev/null +++ b/Language/Haskell/GhcMod/Stderr.hs @@ -0,0 +1,88 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +-- Derived from process:System.Process +-- Copyright (c) The University of Glasgow 2004-2008 + +module Language.Haskell.GhcMod.Stderr where + +import Data.List +import System.IO +import System.Exit +import System.Process +import Control.Monad +import Control.DeepSeq +import Control.Exception +import Control.Concurrent + +stdoutGateway :: Chan String -> IO () +stdoutGateway chan = do + l <- readChan chan + putStrLn l + stdoutGateway chan + +readProcessStderrChan :: + Chan String -> FilePath -> [String] -> String -> IO String +readProcessStderrChan cout exe args input = do + let cp = (proc exe args) { + std_out = CreatePipe + , std_err = CreatePipe + , std_in = CreatePipe + } + (Just i, Just o, Just e, h) <- createProcess cp + + _ <- forkIO $ reader e + + output <- hGetContents o + withForkWait (evaluate $ rnf output) $ \waitOut -> do + + -- now write any input + unless (null input) $ + ignoreSEx $ hPutStr i input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + ignoreSEx $ hClose i + + -- wait on the output + waitOut + hClose o + + res <- waitForProcess h + case res of + ExitFailure rv -> + processFailedException "readProcessStderrChan" exe args rv + ExitSuccess -> + return output + + where + ignoreSEx = handle (\(SomeException _) -> return ()) + reader h = ignoreSEx $ do + l <- hGetLine h + writeChan cout l + reader h + +withForkWait :: IO () -> (IO () -> IO a) -> IO a +withForkWait async body = do + waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) + mask $ \restore -> do + tid <- forkIO $ try (restore async) >>= putMVar waitVar + let wait = takeMVar waitVar >>= either throwIO return + restore (body wait) `onException` killThread tid + +processFailedException :: String -> String -> [String] -> Int -> IO a +processFailedException fn exe args rv = + error $ concat [fn, ": ", exe, " " + , intercalate " " (map show args) + , " (exit " ++ show rv ++ ")"] diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 66bb80f..6c61f9e 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -334,7 +334,7 @@ resolveGmComponent mums c@GmComponent {..} = do [ "-optP-include", "-optP" ++ macrosHeaderPath ] ] -resolveEntrypoint :: (IOish m, GmLog m) +resolveEntrypoint :: (IOish m, GmEnv m, GmLog m) => Cradle -> GmComponent 'GMCRaw ChEntrypoint -> m (GmComponent 'GMCRaw (Set ModulePath)) @@ -366,7 +366,7 @@ resolveChEntrypoints srcDir ChSetupEntrypoint = do chModToMod :: ChModuleName -> ModuleName chModToMod (ChModuleName mn) = mkModuleName mn -resolveModule :: (MonadIO m, GmLog m) => +resolveModule :: (MonadIO m, GmEnv m, GmLog m) => HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath) resolveModule env _srcDirs (Right mn) = liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 9156425..934d148 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -13,6 +13,7 @@ import Control.Monad.Error (Error(..)) import qualified Control.Monad.IO.Class as MTL import Control.Exception (Exception) import Control.Applicative +import Control.Concurrent import Control.Monad import Data.Serialize import Data.Version @@ -72,6 +73,9 @@ data Options = Options { outputStyle :: OutputStyle -- | Line separator string. , lineSeparator :: LineSeparator + -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout, + -- @snd@ is stderr prefix. + , linePrefix :: Maybe (String, String) -- | Verbosity , logLevel :: GmLogLevel -- | @ghc@ program name. @@ -96,6 +100,7 @@ defaultOptions :: Options defaultOptions = Options { outputStyle = PlainStyle , lineSeparator = LineSeparator "\0" + , linePrefix = Nothing , logLevel = GmWarning , ghcProgram = "ghc" , ghcPkgProgram = "ghc-pkg" @@ -125,9 +130,13 @@ data Cradle = Cradle { , cradleCabalFile :: Maybe FilePath } deriving (Eq, Show) +data GmOutput = GmOutputStdio + | GmOutputChan (Chan String) + data GhcModEnv = GhcModEnv { gmOptions :: Options , gmCradle :: Cradle + , gmOutput :: GmOutput } data GhcModLog = GhcModLog { diff --git a/ghc-mod.cabal b/ghc-mod.cabal index b935bd0..381cee0 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -119,11 +119,13 @@ Library Language.Haskell.GhcMod.Modules Language.Haskell.GhcMod.Monad Language.Haskell.GhcMod.Monad.Types + Language.Haskell.GhcMod.Output Language.Haskell.GhcMod.PathsAndFiles Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.Pretty Language.Haskell.GhcMod.Read Language.Haskell.GhcMod.SrcUtils + Language.Haskell.GhcMod.Stderr Language.Haskell.GhcMod.Target Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Utils diff --git a/src/GHCMod.hs b/src/GHCMod.hs index a81f938..8e94ab7 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -74,10 +74,10 @@ usage = \\n" ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++ "*Commands*\n\ - \ - version | --version\n\ + \ - version\n\ \ Print the version of the program.\n\ \\n\ - \ - help | --help\n\ + \ - help\n\ \ Print this help message.\n\ \\n\ \ - list [FLAGS...] | modules [FLAGS...]\n\ @@ -259,8 +259,12 @@ globalArgSpec = , option "l" ["tolisp"] "Format output as an S-Expression" $ NoArg $ \o -> Right $ o { outputStyle = LispStyle } - , option "b" ["boundary"] "Output line separator"$ + , option "b" ["boundary", "line-seperator"] "Output line separator"$ reqArg "SEP" $ \s o -> Right $ o { lineSeparator = LineSeparator s } + , option "" ["line-prefix"] "Output line separator"$ + reqArg "OUT,ERR" $ \s o -> let + [out, err] = splitOn "," s + in Right $ o { linePrefix = Just (out, err) } , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $ reqArg "OPT" $ \g o -> Right $ @@ -339,25 +343,29 @@ main :: IO () main = handler $ do hSetEncoding stdout utf8 args <- getArgs - - -- This doesn't handle --help and --version being given after any global - -- options. To do that we'd have to fiddle with getOpt. case parseGlobalArgs args of - Left e -> case globalCommands args of - Just s -> putStr s - Nothing -> throw e - - Right res@(_,cmdArgs) -> - case globalCommands cmdArgs of - Just s -> putStr s - Nothing -> progMain res + Left e -> throw e + Right res -> progMain res progMain :: (Options,[String]) -> IO () -progMain (globalOptions,cmdArgs) = do - (res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs - case res of - Right () -> return () - Left e -> exitError $ renderStyle ghcModStyle (gmeDoc e) +progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ do + case globalCommands cmdArgs of + Just s -> gmPutStr s + Nothing -> ghcCommands cmdArgs + where + hndle action = do + (e, _l) <- action + case e of + Right _ -> + return () + Left ed -> + exitError $ renderStyle ghcModStyle (gmeDoc ed) + +globalCommands :: [String] -> Maybe String +globalCommands (cmd:_) + | cmd == "help" = Just usage + | cmd == "version" = Just ghcModVersion +globalCommands _ = Nothing -- ghc-modi legacyInteractive :: IOish m => GhcModT m () @@ -367,10 +375,10 @@ legacyInteractive = do world <- getCurrentWorld legacyInteractiveLoop symdbreq world -bug :: String -> IO () +bug :: IOish m => String -> GhcModT m () bug msg = do - putStrLn $ notGood $ "BUG: " ++ msg - exitFailure + gmPutStrLn $ notGood $ "BUG: " ++ msg + liftIO exitFailure notGood :: String -> String notGood msg = "NG " ++ escapeNewlines msg @@ -422,20 +430,13 @@ legacyInteractiveLoop symdbreq world = do "" -> liftIO $ exitSuccess _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" - liftIO $ putStr res >> putStrLn "OK" >> hFlush stdout + gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout) legacyInteractiveLoop symdbreq world -globalCommands :: [String] -> Maybe String -globalCommands [] = Nothing -globalCommands (cmd:_) = case cmd of - _ | cmd == "help" -> Just usage - _ | cmd == "version" -> Just ghcModVersion - _ -> Nothing - ghcCommands :: IOish m => [String] -> GhcModT m () ghcCommands [] = fatalError "No command given (try --help)" ghcCommands (cmd:args) = do - liftIO . putStr =<< action args + gmPutStr =<< action args where action = case cmd of _ | cmd == "list" || cmd == "modules" -> modulesCmd From 09c3c5603cc485a945987a2d6944874b5e9f0c86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Thu, 13 Aug 2015 09:01:58 +0200 Subject: [PATCH 183/207] Fix missing newlines --- Language/Haskell/GhcMod/CabalHelper.hs | 21 ++-- Language/Haskell/GhcMod/Monad.hs | 2 +- Language/Haskell/GhcMod/Output.hs | 148 +++++++++++++++++++++++-- Language/Haskell/GhcMod/Stderr.hs | 88 --------------- Language/Haskell/GhcMod/Types.hs | 15 ++- ghc-mod.cabal | 1 - 6 files changed, 166 insertions(+), 109 deletions(-) delete mode 100644 Language/Haskell/GhcMod/Stderr.hs diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 9193ba8..36c82a1 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -39,7 +39,7 @@ import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Logging -import Language.Haskell.GhcMod.Stderr +import Language.Haskell.GhcMod.Output import System.FilePath import Prelude hiding ((.)) @@ -53,7 +53,9 @@ getGhcMergedPkgOptions = chCached Cached { cacheLens = Just (lGmcMergedPkgOptions . lGmCaches), cacheFile = mergedPkgOptsCacheFile, cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do - opts <- withCabal $ runQuery' progs rootdir distdir $ ghcMergedPkgOptions + readProc <- gmReadProcess + opts <- withCabal $ runQuery'' readProc progs rootdir distdir $ + ghcMergedPkgOptions return ([setupConfigPath], opts) } @@ -79,7 +81,8 @@ getPackageDbStack' = chCached Cached { cacheLens = Just (lGmcPackageDbStack . lGmCaches), cacheFile = pkgDbStackCacheFile, cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do - dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery' progs rootdir distdir packageDbStack + readProc <- gmReadProcess + dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery'' readProc progs rootdir distdir packageDbStack return ([setupConfigPath, sandboxConfigFile], dbs) } @@ -98,8 +101,9 @@ getComponents :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m) getComponents = chCached Cached { cacheLens = Just (lGmcComponents . lGmCaches), cacheFile = cabalHelperCacheFile, - cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma -> - runQuery' progs rootdir distdir $ do + cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma -> do + readProc <- gmReadProcess + runQuery'' readProc progs rootdir distdir $ do q <- join7 <$> ghcOptions <*> ghcPkgOptions @@ -126,6 +130,7 @@ withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a withCabal action = do crdl <- cradle opts <- options + readProc <- gmReadProcess let projdir = cradleRootDir crdl distdir = projdir "dist" @@ -138,7 +143,7 @@ withCabal action = do pkgDbStackOutOfSync <- case mCusPkgDbStack of Just cusPkgDbStack -> do - pkgDb <- runQuery' (helperProgs opts) projdir distdir $ + pkgDb <- runQuery'' readProc (helperProgs opts) projdir distdir $ map chPkgToGhcPkg <$> packageDbStack return $ pkgDb /= cusPkgDbStack @@ -163,9 +168,9 @@ withCabal action = do then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ] else [] ++ map pkgDbArg cusPkgStack - liftIO $ void $ readProcess (T.cabalProgram opts) ("configure":progOpts) "" + liftIO $ void $ readProc (T.cabalProgram opts) ("configure":progOpts) "" gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" - liftIO $ writeAutogenFiles readProcess projdir distdir + liftIO $ writeAutogenFiles readProc projdir distdir action pkgDbArg :: GhcPkgDb -> String diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 0b392c9..adc7114 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -35,7 +35,7 @@ import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Target -import Language.Haskell.GhcMod.Stderr +import Language.Haskell.GhcMod.Output import Control.Arrow (first) import Control.Applicative diff --git a/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs index 1ca9ee7..fffb1c2 100644 --- a/Language/Haskell/GhcMod/Output.hs +++ b/Language/Haskell/GhcMod/Output.hs @@ -1,13 +1,38 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +-- Derived from process:System.Process +-- Copyright (c) The University of Glasgow 2004-2008 + module Language.Haskell.GhcMod.Output ( gmPutStr , gmErrStr , gmPutStrLn , gmErrStrLn + , gmReadProcess + , stdoutGateway ) where -import Data.Char +import Data.List import System.IO +import System.Exit +import System.Process import Control.Monad +import Control.DeepSeq +import Control.Exception import Control.Concurrent import Language.Haskell.GhcMod.Types hiding (LineSeparator) @@ -19,36 +44,139 @@ withLines f s = let in case s of [] -> res - _ | generalCategory (last s) /= LineSeparator -> + _ | not $ isTerminated s -> reverse $ drop 1 $ reverse res _ -> res -outputFns :: (GmEnv m, MonadIO m') => m (String -> m' (), String -> m' ()) +isTerminated :: String -> Bool +isTerminated "" = False +isTerminated s = isNewline (last s) + +isNewline :: Char -> Bool +isNewline c = c == '\n' + +toGmLines :: String -> (GmLines String) +toGmLines "" = GmLines GmPartial "" +toGmLines s | isNewline (last s) = GmLines GmTerminated s +toGmLines s = GmLines GmPartial s + +outputFns :: (GmEnv m, MonadIO m') => m (GmLines String -> m' (), GmLines String -> m' ()) outputFns = do GhcModEnv {..} <- gmeAsk let Options {..} = gmOptions let pfx f = withLines f - let (outPfx, errPfx) = case linePrefix of - Nothing -> ( id, id ) - Just (op, ep) -> ( pfx (op++), pfx (ep++) ) + + let outPfx, errPfx :: GmLines String -> GmLines String + (outPfx, errPfx) = + case linePrefix of + Nothing -> ( id, id ) + Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) ) return $ case gmOutput of GmOutputStdio -> - (liftIO . putStr . outPfx , liftIO . hPutStr stderr . errPfx) + ( liftIO . putStr . unGmLine . outPfx + , liftIO . hPutStr stderr . unGmLine . errPfx) GmOutputChan c -> - (liftIO . writeChan c . outPfx, liftIO . writeChan c . errPfx) + ( liftIO . writeChan c . (,) GmOut . outPfx + , liftIO . writeChan c . (,) GmErr .errPfx) gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn :: (MonadIO m, GmEnv m) => String -> m () gmPutStr str = do putOut <- fst `liftM` outputFns - putOut str + putOut $ toGmLines str gmPutStrLn = gmPutStr . (++"\n") gmErrStrLn = gmErrStr . (++"\n") gmErrStr str = do putErr <- snd `liftM` outputFns - putErr str + putErr $ toGmLines str + +gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String) +gmReadProcess = do + GhcModEnv {..} <- gmeAsk + case gmOutput of + GmOutputChan _ -> + readProcessStderrChan + GmOutputStdio -> + return $ readProcess + +stdoutGateway :: Chan (GmStream, GmLines String) -> IO () +stdoutGateway chan = go ("", "") + where + go buf@(obuf, ebuf) = do + (stream, GmLines ty l) <- readChan chan + case ty of + GmTerminated -> + case stream of + GmOut -> putStr (obuf++l) >> go ("", ebuf) + GmErr -> putStr (ebuf++l) >> go (obuf, "") + GmPartial -> case reverse $ lines l of + [] -> go buf + [x] -> go (appendBuf stream buf x) + x:xs -> do + putStr $ unlines $ reverse xs + go (appendBuf stream buf x) + + appendBuf GmOut (obuf, ebuf) s = (obuf++s, ebuf) + appendBuf GmErr (obuf, ebuf) s = (obuf, ebuf++s) + + +readProcessStderrChan :: + GmEnv m => m (FilePath -> [String] -> String -> IO String) +readProcessStderrChan = do + (_, e) <- outputFns + return $ go e + where + go :: (GmLines String -> IO ()) -> FilePath -> [String] -> String -> IO String + go putErr exe args input = do + let cp = (proc exe args) { + std_out = CreatePipe + , std_err = CreatePipe + , std_in = CreatePipe + } + (Just i, Just o, Just e, h) <- createProcess cp + + _ <- forkIO $ reader e + + output <- hGetContents o + withForkWait (evaluate $ rnf output) $ \waitOut -> do + + -- now write any input + unless (null input) $ + ignoreSEx $ hPutStr i input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + ignoreSEx $ hClose i + + -- wait on the output + waitOut + hClose o + + res <- waitForProcess h + case res of + ExitFailure rv -> + processFailedException "readProcessStderrChan" exe args rv + ExitSuccess -> + return output + where + ignoreSEx = handle (\(SomeException _) -> return ()) + reader h = ignoreSEx $ do + putErr . toGmLines . (++"\n") =<< hGetLine h + reader h + +withForkWait :: IO () -> (IO () -> IO a) -> IO a +withForkWait async body = do + waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) + mask $ \restore -> do + tid <- forkIO $ try (restore async) >>= putMVar waitVar + let wait = takeMVar waitVar >>= either throwIO return + restore (body wait) `onException` killThread tid + +processFailedException :: String -> String -> [String] -> Int -> IO a +processFailedException fn exe args rv = + error $ concat [fn, ": ", exe, " " + , intercalate " " (map show args) + , " (exit " ++ show rv ++ ")"] diff --git a/Language/Haskell/GhcMod/Stderr.hs b/Language/Haskell/GhcMod/Stderr.hs deleted file mode 100644 index 198f062..0000000 --- a/Language/Haskell/GhcMod/Stderr.hs +++ /dev/null @@ -1,88 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU Affero General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU Affero General Public License for more details. --- --- You should have received a copy of the GNU Affero General Public License --- along with this program. If not, see . - --- Derived from process:System.Process --- Copyright (c) The University of Glasgow 2004-2008 - -module Language.Haskell.GhcMod.Stderr where - -import Data.List -import System.IO -import System.Exit -import System.Process -import Control.Monad -import Control.DeepSeq -import Control.Exception -import Control.Concurrent - -stdoutGateway :: Chan String -> IO () -stdoutGateway chan = do - l <- readChan chan - putStrLn l - stdoutGateway chan - -readProcessStderrChan :: - Chan String -> FilePath -> [String] -> String -> IO String -readProcessStderrChan cout exe args input = do - let cp = (proc exe args) { - std_out = CreatePipe - , std_err = CreatePipe - , std_in = CreatePipe - } - (Just i, Just o, Just e, h) <- createProcess cp - - _ <- forkIO $ reader e - - output <- hGetContents o - withForkWait (evaluate $ rnf output) $ \waitOut -> do - - -- now write any input - unless (null input) $ - ignoreSEx $ hPutStr i input - -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE - ignoreSEx $ hClose i - - -- wait on the output - waitOut - hClose o - - res <- waitForProcess h - case res of - ExitFailure rv -> - processFailedException "readProcessStderrChan" exe args rv - ExitSuccess -> - return output - - where - ignoreSEx = handle (\(SomeException _) -> return ()) - reader h = ignoreSEx $ do - l <- hGetLine h - writeChan cout l - reader h - -withForkWait :: IO () -> (IO () -> IO a) -> IO a -withForkWait async body = do - waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) - mask $ \restore -> do - tid <- forkIO $ try (restore async) >>= putMVar waitVar - let wait = takeMVar waitVar >>= either throwIO return - restore (body wait) `onException` killThread tid - -processFailedException :: String -> String -> [String] -> Int -> IO a -processFailedException fn exe args rv = - error $ concat [fn, ": ", exe, " " - , intercalate " " (map show args) - , " (exit " ++ show rv ++ ")"] diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 934d148..859086c 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -130,8 +130,21 @@ data Cradle = Cradle { , cradleCabalFile :: Maybe FilePath } deriving (Eq, Show) + +data GmStream = GmOut | GmErr + deriving (Show) + +data GmLineType = GmTerminated | GmPartial + deriving (Show) + +data GmLines a = GmLines GmLineType a + deriving (Show, Functor) + +unGmLine :: GmLines a -> a +unGmLine (GmLines _ s) = s + data GmOutput = GmOutputStdio - | GmOutputChan (Chan String) + | GmOutputChan (Chan (GmStream, GmLines String)) data GhcModEnv = GhcModEnv { gmOptions :: Options diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 381cee0..15dda31 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -125,7 +125,6 @@ Library Language.Haskell.GhcMod.Pretty Language.Haskell.GhcMod.Read Language.Haskell.GhcMod.SrcUtils - Language.Haskell.GhcMod.Stderr Language.Haskell.GhcMod.Target Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Utils From eafde94913e82142a1e399f9401b564d7e9b7cbb Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 7 Jun 2015 20:36:49 +0200 Subject: [PATCH 184/207] Expose functions for integration with HaRe --- .gitignore | 2 ++ Language/Haskell/GhcMod/Debug.hs | 8 +++----- Language/Haskell/GhcMod/Internal.hs | 19 +++++++++++++++++++ Language/Haskell/GhcMod/Monad/Types.hs | 15 +++++++++++++-- Language/Haskell/GhcMod/Target.hs | 16 ++++++++++++---- src/GHCMod.hs | 2 +- src/Misc.hs | 2 +- 7 files changed, 51 insertions(+), 13 deletions(-) diff --git a/.gitignore b/.gitignore index 1558560..f280993 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,5 @@ cabal.sandbox.config # For instance, .#Help.page # .#* cabal-dev +/TAGS +/tags diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 42abedb..54e85d2 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -12,7 +12,6 @@ import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Internal -import Language.Haskell.GhcMod.CabalHelper import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Pretty import Language.Haskell.GhcMod.Utils @@ -44,8 +43,8 @@ debugInfo = do cabalDebug :: IOish m => GhcModT m [String] cabalDebug = do - crdl@Cradle {..} <- cradle - mcs <- resolveGmComponents Nothing =<< mapM (resolveEntrypoint crdl) =<< getComponents + Cradle {..} <- cradle + mcs <- cabalResolvedComponents let entrypoints = Map.map gmcEntrypoints mcs graphs = Map.map gmcHomeModuleGraph mcs opts = Map.map gmcGhcOpts mcs @@ -69,8 +68,7 @@ componentInfo ts = do -- useful function from there. crdl <- cradle sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts - comps <- mapM (resolveEntrypoint crdl) =<< getComponents - mcs <- resolveGmComponents Nothing comps + mcs <- cabalResolvedComponents let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn candidates = findCandidates $ map snd mdlcs diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index 1e01d7b..bb9fae7 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -8,6 +8,9 @@ module Language.Haskell.GhcMod.Internal ( , PackageVersion , PackageId , IncludeDir + , GmlT(..) + , MonadIO(..) + , GmEnv(..) -- * Various Paths , ghcLibDir , ghcModExecutable @@ -20,9 +23,18 @@ module Language.Haskell.GhcMod.Internal ( , GhcModState , CompilerMode(..) , GhcModLog + , GmLog(..) + , GmLogLevel(..) + , gmSetLogLevel -- * Monad utilities , runGhcModT' , hoistGhcModT + , runGmlT + , runGmlT' + , gmlGetSession + , gmlSetSession + , loadTargets + , cabalResolvedComponents -- ** Accessing 'GhcModEnv' and 'GhcModState' , options , cradle @@ -35,13 +47,20 @@ module Language.Haskell.GhcMod.Internal ( , World , getCurrentWorld , didWorldChange + -- * Cabal Helper + , ModulePath(..) + , GmComponent(..) + , GmComponentType(..) + , GmModuleGraph(..) ) where import GHC.Paths (libdir) +import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logger +import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 0074ec3..5c877b9 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -50,6 +50,8 @@ module Language.Haskell.GhcMod.Monad.Types ( -- * Re-exporting convenient stuff , MonadIO , liftIO + , gmlGetSession + , gmlSetSession ) where -- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. @@ -349,13 +351,22 @@ gmLiftWithInner f = liftWith f >>= restoreT . return type GmGhc m = (IOish m, GhcMonad m) instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where - getSession = do + getSession = gmlGetSession + setSession = gmlSetSession + +-- --------------------------------------------------------------------- + +gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv +gmlGetSession = do ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet GHC.liftIO $ readIORef ref - setSession a = do + +gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m () +gmlSetSession a = do ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet GHC.liftIO $ flip writeIORef a ref +-- --------------------------------------------------------------------- instance GhcMonad LightGhc where getSession = (GHC.liftIO . readIORef) =<< LightGhc ask setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 66bb80f..a731203 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -184,11 +184,9 @@ targetGhcOptions crdl sefnmn = do cabalOpts :: Cradle -> GhcModT m [String] cabalOpts Cradle{..} = do - comps <- mapM (resolveEntrypoint crdl) =<< getComponents - mcs <- cached cradleRootDir resolvedComponentsCache comps + mcs <- cabalResolvedComponents let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn - cns = map gmcName comps candidates = findCandidates $ map snd mdlcs let noCandidates = Set.null candidates @@ -196,7 +194,10 @@ targetGhcOptions crdl sefnmn = do if noCandidates && noModuleHasAnyAssignment then do - gmLog GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to picking first component in cabal file." + -- First component should be ChLibName, if no lib will take lexically first exe. + let cns = filter (/= ChSetupHsName) $ Map.keys mcs + + gmLog GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file." return $ gmcGhcOpts $ fromJust $ Map.lookup (head cns) mcs else do when noCandidates $ @@ -476,3 +477,10 @@ needsFallback = any $ \ms -> #if __GLASGOW_HASKELL__ >= 708 || (Opt_PatternSynonyms `xopt` df) #endif + +cabalResolvedComponents :: (IOish m) => + GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) +cabalResolvedComponents = do + crdl@(Cradle{..}) <- cradle + comps <- mapM (resolveEntrypoint crdl) =<< getComponents + cached cradleRootDir resolvedComponentsCache comps diff --git a/src/GHCMod.hs b/src/GHCMod.hs index a81f938..570e125 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -14,7 +14,7 @@ import Data.Char (isSpace) import Data.Maybe import Exception import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal +import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) import Paths_ghc_mod import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import qualified System.Console.GetOpt as O diff --git a/src/Misc.hs b/src/Misc.hs index 834f0c2..2064a7f 100644 --- a/src/Misc.hs +++ b/src/Misc.hs @@ -13,7 +13,7 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Prelude import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal +import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) ---------------------------------------------------------------- From cbfa26eb1647b149f37f2d1639a6b6d47fa23acc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 03:48:29 +0200 Subject: [PATCH 185/207] Make sure cabal-helper is ready before invoking dumpsym --- Language/Haskell/GhcMod/CabalHelper.hs | 9 +++++++++ Language/Haskell/GhcMod/Internal.hs | 2 ++ src/GHCMod.hs | 1 + 3 files changed, 12 insertions(+) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 36c82a1..006607b 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -20,6 +20,7 @@ module Language.Haskell.GhcMod.CabalHelper ( getComponents , getGhcMergedPkgOptions , getPackageDbStack + , prepareCabalHelper ) #endif where @@ -126,6 +127,14 @@ getComponents = chCached Cached { , a == a' ] +prepareCabalHelper :: (IOish m, GmEnv m, GmLog m) => m () +prepareCabalHelper = do + crdl <- cradle + let projdir = cradleRootDir crdl + distdir = projdir "dist" + readProc <- gmReadProcess + liftIO $ prepare readProc projdir distdir + withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a withCabal action = do crdl <- cradle diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index bb9fae7..143dc5f 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -52,6 +52,7 @@ module Language.Haskell.GhcMod.Internal ( , GmComponent(..) , GmComponentType(..) , GmModuleGraph(..) + , prepareCabalHelper ) where import GHC.Paths (libdir) @@ -65,6 +66,7 @@ import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World +import Language.Haskell.GhcMod.CabalHelper -- | Obtaining the directory for ghc system libraries. ghcLibDir :: FilePath diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 57c914e..06156f9 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -371,6 +371,7 @@ globalCommands _ = Nothing legacyInteractive :: IOish m => GhcModT m () legacyInteractive = do opt <- options + prepareCabalHelper symdbreq <- liftIO $ newSymDbReq opt world <- getCurrentWorld legacyInteractiveLoop symdbreq world From 0b5de23ac9daed7c982e18b91c4ae338c75190ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 03:51:50 +0200 Subject: [PATCH 186/207] Wrap dumpsym in stderr mangling readProc as well just in case --- Language/Haskell/GhcMod/Find.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 1275656..eb7d99d 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -26,6 +26,7 @@ import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World (timedPackageCaches) +import Language.Haskell.GhcMod.Output import Name (getOccString) import Module (moduleName) import System.Directory (doesFileExist, getModificationTime) @@ -72,7 +73,8 @@ loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb = do ghcMod <- liftIO ghcModExecutable tmpdir <- cradleTempDir <$> cradle - file <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] "" + readProc <- gmReadProcess + file <- liftIO $ chop <$> readProc ghcMod ["dumpsym", tmpdir] "" !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) return $ SymbolDb { table = db From f998c63c738b37f69a956787f24ab76fa82a91f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 04:28:22 +0200 Subject: [PATCH 187/207] Fix prepareCabalHelper when dist/ doesn't exist yet --- Language/Haskell/GhcMod/CabalHelper.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 006607b..bf180c8 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -133,7 +133,7 @@ prepareCabalHelper = do let projdir = cradleRootDir crdl distdir = projdir "dist" readProc <- gmReadProcess - liftIO $ prepare readProc projdir distdir + withCabal $ liftIO $ prepare readProc projdir distdir withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a withCabal action = do From 55bf578b877dd87fe93a75f1afcc8b00e58617bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 05:57:33 +0200 Subject: [PATCH 188/207] Put line-prefix'es on exceptions too --- Language/Haskell/GhcMod.hs | 2 ++ Language/Haskell/GhcMod/Internal.hs | 3 +++ Language/Haskell/GhcMod/Output.hs | 39 +++++++++++++++++++++-------- src/GHCMod.hs | 25 ++++++++++-------- 4 files changed, 48 insertions(+), 21 deletions(-) diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 45d4401..d1eecd8 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -61,6 +61,8 @@ module Language.Haskell.GhcMod ( , gmErrStr , gmPutStrLn , gmErrStrLn + , gmUnsafePutStrLn + , gmUnsafeErrStrLn ) where import Language.Haskell.GhcMod.Boot diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index 143dc5f..ea480c8 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -53,6 +53,9 @@ module Language.Haskell.GhcMod.Internal ( , GmComponentType(..) , GmModuleGraph(..) , prepareCabalHelper + -- * Misc stuff + , GHandler(..) + , gcatches ) where import GHC.Paths (libdir) diff --git a/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs index fffb1c2..e96956a 100644 --- a/Language/Haskell/GhcMod/Output.hs +++ b/Language/Haskell/GhcMod/Output.hs @@ -22,6 +22,8 @@ module Language.Haskell.GhcMod.Output ( , gmErrStr , gmPutStrLn , gmErrStrLn + , gmUnsafePutStrLn + , gmUnsafeErrStrLn , gmReadProcess , stdoutGateway ) where @@ -60,20 +62,29 @@ toGmLines "" = GmLines GmPartial "" toGmLines s | isNewline (last s) = GmLines GmTerminated s toGmLines s = GmLines GmPartial s -outputFns :: (GmEnv m, MonadIO m') => m (GmLines String -> m' (), GmLines String -> m' ()) +outputFns :: (GmEnv m, MonadIO m') + => m (GmLines String -> m' (), GmLines String -> m' ()) outputFns = do - GhcModEnv {..} <- gmeAsk - let Options {..} = gmOptions + opts <- options + env <- gmeAsk + return $ outputFns' opts (gmOutput env) - let pfx f = withLines f +outputFns' :: MonadIO m' + => Options + -> GmOutput + -> (GmLines String -> m' (), GmLines String -> m' ()) +outputFns' opts output = let + Options {..} = opts - let outPfx, errPfx :: GmLines String -> GmLines String - (outPfx, errPfx) = - case linePrefix of - Nothing -> ( id, id ) - Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) ) + pfx f = withLines f - return $ case gmOutput of + outPfx, errPfx :: GmLines String -> GmLines String + (outPfx, errPfx) = + case linePrefix of + Nothing -> ( id, id ) + Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) ) + in + case output of GmOutputStdio -> ( liftIO . putStr . unGmLine . outPfx , liftIO . hPutStr stderr . unGmLine . errPfx) @@ -95,6 +106,12 @@ gmErrStr str = do putErr <- snd `liftM` outputFns putErr $ toGmLines str +-- | Only use these when you're sure there are no other writers on stdout +gmUnsafePutStrLn, gmUnsafeErrStrLn + :: MonadIO m => Options -> String -> m () +gmUnsafePutStrLn opts = (fst $ outputFns' opts GmOutputStdio) . toGmLines +gmUnsafeErrStrLn opts = (snd $ outputFns' opts GmOutputStdio) . toGmLines + gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String) gmReadProcess = do GhcModEnv {..} <- gmeAsk @@ -177,6 +194,6 @@ withForkWait async body = do processFailedException :: String -> String -> [String] -> Int -> IO a processFailedException fn exe args rv = - error $ concat [fn, ": ", exe, " " + error $ concat [ fn, ": ", exe, " " , intercalate " " (map show args) , " (exit " ++ show rv ++ ")"] diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 06156f9..7c738cc 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -23,7 +23,7 @@ import System.Directory (setCurrentDirectory, getAppUserDataDirectory, removeDirectoryRecursive) import System.Environment (getArgs) import System.Exit (exitFailure) -import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush) +import System.IO (stdout, hSetEncoding, utf8, hFlush) import System.Exit (exitSuccess) import Text.PrettyPrint import Prelude @@ -327,20 +327,21 @@ data InteractiveOptions = InteractiveOptions { ghcModExtensions :: Bool } -handler :: IO a -> IO a -handler = flip catches $ - [ Handler $ \(FatalError msg) -> exitError msg - , Handler $ \(InvalidCommandLine e) -> do +handler :: IOish m => GhcModT m a -> GhcModT m a +handler = flip gcatches $ + [ GHandler $ \(FatalError msg) -> exitError msg + , GHandler $ \(InvalidCommandLine e) -> do case e of Left cmd -> exitError $ "Usage for `"++cmd++"' command:\n\n" ++ (cmdUsage cmd usage) ++ "\n" ++ "ghc-mod: Invalid command line form." Right msg -> exitError $ "ghc-mod: " ++ msg + , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e ] main :: IO () -main = handler $ do +main = do hSetEncoding stdout utf8 args <- getArgs case parseGlobalArgs args of @@ -348,7 +349,7 @@ main = handler $ do Right res -> progMain res progMain :: (Options,[String]) -> IO () -progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ do +progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do case globalCommands cmdArgs of Just s -> gmPutStr s Nothing -> ghcCommands cmdArgs @@ -359,7 +360,7 @@ progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ do Right _ -> return () Left ed -> - exitError $ renderStyle ghcModStyle (gmeDoc ed) + exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc ed) globalCommands :: [String] -> Maybe String globalCommands (cmd:_) @@ -471,8 +472,12 @@ newtype InvalidCommandLine = InvalidCommandLine (Either String String) deriving (Show, Typeable) instance Exception InvalidCommandLine -exitError :: String -> IO a -exitError msg = hPutStrLn stderr (dropWhileEnd (=='\n') msg) >> exitFailure +exitError :: IOish m => String -> GhcModT m a +exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure + +exitError' :: Options -> String -> IO a +exitError' opts msg = + gmUnsafeErrStrLn opts (dropWhileEnd (=='\n') msg) >> liftIO exitFailure fatalError :: String -> a fatalError s = throw $ FatalError $ "ghc-mod: " ++ s From 54c2be20b686cddaa29c2e1fc1101799d5e462d8 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 13 Aug 2015 14:40:48 +0900 Subject: [PATCH 189/207] better debug logging of Elisp. --- elisp/ghc-process.el | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index d9c0821..03cc62d 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -78,6 +78,9 @@ (if (not (get-buffer pbuf)) (setq ghc-process-running nil) ;; just in case (ghc-with-current-buffer (process-buffer process) + (when ghc-debug + (ghc-with-debug-buffer + (insert string))) (goto-char (point-max)) (insert string) (forward-line -1) @@ -86,17 +89,9 @@ (if ghc-process-hook (funcall ghc-process-hook)) (goto-char (point-min)) (funcall ghc-process-callback 'ok) - (when ghc-debug - (let ((cbuf (current-buffer))) - (ghc-with-debug-buffer - (insert-buffer-substring cbuf)))) (setq ghc-process-running nil)) ((looking-at "^NG ") (funcall ghc-process-callback 'ng) - (when ghc-debug - (let ((cbuf (current-buffer))) - (ghc-with-debug-buffer - (insert-buffer-substring cbuf)))) (setq ghc-process-running nil))))))) (defun ghc-process-sentinel (process event) From 002008aa301c0e09229b6c8fe2d0ed6231ec866c Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 13 Aug 2015 16:50:19 +0900 Subject: [PATCH 190/207] splitting stdout and stderr. --- elisp/ghc-process.el | 43 ++++++++++++++++++++++++++++++++++++++----- 1 file changed, 38 insertions(+), 5 deletions(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 03cc62d..d6d4a35 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -21,7 +21,9 @@ (defvar-local ghc-process-hook nil) (defvar-local ghc-process-root nil) -(defvar ghc-command "ghc-mod") +(defvar ghc-command "Mock") + +(defvar ghc-error-buffer "*GHC Error*") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -74,15 +76,46 @@ pro)) (defun ghc-process-filter (process string) - (let ((pbuf (process-buffer process))) + (let* ((pbuf (process-buffer process)) + (tbufname (concat " tmp " (buffer-name pbuf))) + tbuf) (if (not (get-buffer pbuf)) (setq ghc-process-running nil) ;; just in case - (ghc-with-current-buffer (process-buffer process) + (ghc-with-current-buffer pbuf (when ghc-debug (ghc-with-debug-buffer (insert string))) - (goto-char (point-max)) - (insert string) + (with-current-buffer (get-buffer-create tbufname) + (setq tbuf (current-buffer)) + (goto-char (point-max)) + (insert string) + (goto-char (point-min)) + (let ((cont t) end out) + (while (and cont (not (eobp))) + (cond + ((looking-at "^O: ") + (setq out t)) + ((looking-at "^E: ") + (setq out nil)) + (t + (setq cont nil))) + (when cont + (forward-line) + (unless (bolp) (setq cont nil))) + (when cont + (delete-region 1 4) + (setq end (point)) + (if out + (with-current-buffer pbuf + (goto-char (point-max)) + (insert-buffer-substring tbuf 1 end)) + (with-current-buffer (get-buffer-create ghc-error-buffer) + (goto-char (point-max)) + (insert-buffer-substring tbuf 1 end) + (display-buffer (current-buffer)) + (redisplay))) + (delete-region 1 end))))) + (goto-char (point-max)) (forward-line -1) (cond ((looking-at "^OK$") From efef2b19eabcb36958f5fe3d1705cf97b1de9c3f Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 13 Aug 2015 17:39:01 +0900 Subject: [PATCH 191/207] scrolling errors. --- elisp/ghc-process.el | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index d6d4a35..7de4bb3 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -110,9 +110,15 @@ (goto-char (point-max)) (insert-buffer-substring tbuf 1 end)) (with-current-buffer (get-buffer-create ghc-error-buffer) - (goto-char (point-max)) - (insert-buffer-substring tbuf 1 end) - (display-buffer (current-buffer)) + (let* ((cbuf (current-buffer)) + cwin) + (unless (get-buffer-window cbuf) (display-buffer cbuf)) + (setq cwin (get-buffer-window cbuf)) + (goto-char (point-max)) + (insert-buffer-substring tbuf 1 end) + (unless (pos-visible-in-window-p (point) cwin) + (with-selected-window cwin + (scroll-up 2)))) (redisplay))) (delete-region 1 end))))) (goto-char (point-max)) From f762209e603e0f2851c61f4394de3786c4cd7149 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 14 Aug 2015 11:36:37 +0900 Subject: [PATCH 192/207] using new ghc-mod. --- elisp/ghc-process.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 7de4bb3..db22ef0 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -21,7 +21,7 @@ (defvar-local ghc-process-hook nil) (defvar-local ghc-process-root nil) -(defvar ghc-command "Mock") +(defvar ghc-command "ghc-mod") (defvar ghc-error-buffer "*GHC Error*") @@ -68,7 +68,9 @@ (t cpro))) (defun ghc-start-process (name buf) - (let* ((opts (append '("legacy-interactive" "-b" "\n" "-l" "-s") (ghc-make-ghc-options))) + (let* ((opts (append '("-b" "\n" "-l" "--line-prefix=O: ,E: ") + (ghc-make-ghc-options) + '("legacy-interactive"))) (pro (apply 'start-file-process name buf ghc-command opts))) (set-process-filter pro 'ghc-process-filter) (set-process-sentinel pro 'ghc-process-sentinel) From cfddddcfe8da8f4121d0ddd930a1447e84275127 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 14 Aug 2015 11:40:57 +0900 Subject: [PATCH 193/207] error buffer is now read-only. --- elisp/ghc-process.el | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index db22ef0..8214aa1 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -112,12 +112,16 @@ (goto-char (point-max)) (insert-buffer-substring tbuf 1 end)) (with-current-buffer (get-buffer-create ghc-error-buffer) - (let* ((cbuf (current-buffer)) + (setq buffer-read-only t) + (let* ((buffer-read-only nil) + (inhibit-read-only t) + (cbuf (current-buffer)) cwin) (unless (get-buffer-window cbuf) (display-buffer cbuf)) (setq cwin (get-buffer-window cbuf)) (goto-char (point-max)) (insert-buffer-substring tbuf 1 end) + (set-buffer-modified-p nil) (unless (pos-visible-in-window-p (point) cwin) (with-selected-window cwin (scroll-up 2)))) From 887ab3c599fe02ef071c26dcb8bb71cd8385b466 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 06:32:20 +0200 Subject: [PATCH 194/207] Don't try to create dist/ in non cabal projects, duh --- Language/Haskell/GhcMod/CabalHelper.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index bf180c8..c9076bb 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -133,7 +133,8 @@ prepareCabalHelper = do let projdir = cradleRootDir crdl distdir = projdir "dist" readProc <- gmReadProcess - withCabal $ liftIO $ prepare readProc projdir distdir + when (cradleProjectType crdl == CabalProject) $ + withCabal $ liftIO $ prepare readProc projdir distdir withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a withCabal action = do From 623cddd8ca05348e1a77ad5085999ea97efa2ef8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 06:48:56 +0200 Subject: [PATCH 195/207] Fix `find` being slow on legacy-interactive --- Language/Haskell/GhcMod/Find.hs | 11 ++++++----- src/GHCMod.hs | 3 ++- src/Misc.hs | 6 +++--- 3 files changed, 11 insertions(+), 9 deletions(-) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index eb7d99d..b001e0d 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -56,7 +56,9 @@ isOutdated db = -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] -- which will be concatenated. 'loadSymbolDb' is called internally. findSymbol :: IOish m => Symbol -> GhcModT m String -findSymbol sym = loadSymbolDb >>= lookupSymbol sym +findSymbol sym = do + tmpdir <- cradleTempDir <$> cradle + loadSymbolDb tmpdir >>= lookupSymbol sym -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] -- which will be concatenated. @@ -69,12 +71,11 @@ lookupSym sym db = M.findWithDefault [] sym $ table db --------------------------------------------------------------- -- | Loading a file and creates 'SymbolDb'. -loadSymbolDb :: IOish m => GhcModT m SymbolDb -loadSymbolDb = do +loadSymbolDb :: IOish m => FilePath -> GhcModT m SymbolDb +loadSymbolDb dir = do ghcMod <- liftIO ghcModExecutable - tmpdir <- cradleTempDir <$> cradle readProc <- gmReadProcess - file <- liftIO $ chop <$> readProc ghcMod ["dumpsym", tmpdir] "" + file <- liftIO $ chop <$> readProc ghcMod ["dumpsym", dir] "" !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) return $ SymbolDb { table = db diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 7c738cc..540260a 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -373,7 +373,8 @@ legacyInteractive :: IOish m => GhcModT m () legacyInteractive = do opt <- options prepareCabalHelper - symdbreq <- liftIO $ newSymDbReq opt + tmpdir <- cradleTempDir <$> cradle + symdbreq <- liftIO $ newSymDbReq opt tmpdir world <- getCurrentWorld legacyInteractiveLoop symdbreq world diff --git a/src/Misc.hs b/src/Misc.hs index 2064a7f..bc5ff9d 100644 --- a/src/Misc.hs +++ b/src/Misc.hs @@ -20,9 +20,9 @@ import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog) data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction) -newSymDbReq :: Options -> IO SymDbReq -newSymDbReq opt = do - let act = runGhcModT opt loadSymbolDb +newSymDbReq :: Options -> FilePath -> IO SymDbReq +newSymDbReq opt dir = do + let act = runGhcModT opt $ loadSymbolDb dir req <- async act ref <- newIORef req return $ SymDbReq ref act From 4df2046672f75a67579d089d066194c016d4ea4d Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 14 Aug 2015 14:21:07 +0900 Subject: [PATCH 196/207] cleaning up the error scrolling. --- elisp/ghc-process.el | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 8214aa1..93b63e5 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -119,13 +119,11 @@ cwin) (unless (get-buffer-window cbuf) (display-buffer cbuf)) (setq cwin (get-buffer-window cbuf)) - (goto-char (point-max)) - (insert-buffer-substring tbuf 1 end) - (set-buffer-modified-p nil) - (unless (pos-visible-in-window-p (point) cwin) - (with-selected-window cwin - (scroll-up 2)))) - (redisplay))) + (with-selected-window cwin + (goto-char (point-max)) + (insert-buffer-substring tbuf 1 end) + (set-buffer-modified-p nil) + (redisplay))))) (delete-region 1 end))))) (goto-char (point-max)) (forward-line -1) From d3a98d90c42d6736fe1e39ec77fbb393bbb94e70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 09:14:53 +0200 Subject: [PATCH 197/207] Bump cabal-helper dependency --- ghc-mod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 15dda31..6f055e7 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -133,7 +133,7 @@ Library , bytestring , cereal >= 0.4 , containers - , cabal-helper == 0.5.* && >= 0.5.0.0 + , cabal-helper == 0.5.* && >= 0.5.1.0 , deepseq , directory , filepath From 9d5f0ad23dde7182323fc3656dcf7ba152bfea00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 09:19:43 +0200 Subject: [PATCH 198/207] Clarify some docs/strings in elisp/ --- elisp/ghc-check.el | 20 ++++++++++---------- elisp/ghc-doc.el | 4 ++-- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el index e468504..214862d 100644 --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -20,7 +20,7 @@ :underline (:style wave :color "orangered")) (t :inherit error)) - "Face used for marking error lines." + "Face used for error lines." :group 'ghc) (defface ghc-face-warn @@ -28,7 +28,7 @@ :underline (:style wave :color "gold")) (t :inherit warning)) - "Face used for marking warning lines." + "Face used for warning lines." :group 'ghc) (defface ghc-face-hole @@ -36,7 +36,7 @@ :underline (:style wave :color "purple")) (t :inherit warning)) - "Face used for marking hole lines." + "Face used for hole lines." :group 'ghc) (defvar ghc-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark))) @@ -46,18 +46,18 @@ (defvar ghc-check-hole-fringe (propertize "_" 'display '(left-fringe horizontal-bar))) (defvar ghc-display-error nil - "*An action to display errors/warnings for 'M-n' and 'M-p: + "*How to display errors/warnings when using 'M-n' and 'M-p': -nil does not display errors/warnings. -'minibuffer displays errors/warnings in the minibuffer. -'other-buffer displays errors/warnings in the other buffer. +nil do not display errors/warnings. +'minibuffer display errors/warnings in the minibuffer. +'other-buffer display errors/warnings in a new buffer. ") (defvar ghc-display-hole 'other-buffer - "*An action to display hole information for 'C-c C-j' and 'C-c C-h' + "*How to display hole information when using 'C-c C-j' and 'C-c C-h' -'minibuffer displays errors/warnings in the minibuffer. -'other-buffer displays errors/warnings in the other buffer" +'minibuffer display errors/warnings in the minibuffer. +'other-buffer display errors/warnings in the a new buffer" ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc-doc.el b/elisp/ghc-doc.el index 46fe2aa..9c61125 100644 --- a/elisp/ghc-doc.el +++ b/elisp/ghc-doc.el @@ -25,7 +25,7 @@ (setq pkg-ver-path (and mod (ghc-resolve-document-path mod))) (if pkg-ver-path (ghc-display-document pkg-ver-path mod haskell-org expr) - (message "No document found")))) + (message "No documentation found")))) (ghc-defstruct pkg-ver-path pkg ver path) @@ -93,7 +93,7 @@ (read-from-minibuffer "Module name: " def ghc-input-map)) (defun ghc-read-expression (def) - (read-from-minibuffer "Expression: " def ghc-input-map)) + (read-from-minibuffer "Identifier: " def ghc-input-map)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 1c19d918133645300d3fe7e0d1e8651471177ec3 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 14 Aug 2015 16:22:57 +0900 Subject: [PATCH 199/207] don't check if the file does not exist. --- elisp/ghc-check.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el index e468504..d9270ba 100644 --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -65,7 +65,8 @@ nil does not display errors/warnings. (defun ghc-check-syntax () (interactive) ;; Only check syntax of visible buffers - (when (get-buffer-window (current-buffer) t) + (when (and (file-exists-p (buffer-file-name)) + (get-buffer-window (current-buffer) t)) (with-timeout (10 (error "ghc process may have hung or exited with an error")) (while ghc-process-running (sleep-for 0.1))) From e126db833a8b3598ff3d0109ac1a81816e453875 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 09:33:22 +0200 Subject: [PATCH 200/207] Disable nuke-caches for now, blowing away dist/ is too risky --- src/GHCMod.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 540260a..094e0de 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -463,7 +463,7 @@ ghcCommands (cmd:args) = do "dumpsym" -> dumpSymbolCmd "boot" -> bootCmd "legacy-interactive" -> legacyInteractiveCmd - "nuke-caches" -> nukeCachesCmd +-- "nuke-caches" -> nukeCachesCmd _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" newtype FatalError = FatalError String deriving (Show, Typeable) From 90061facb9a2a0901a77b265c97efaaf51d4e940 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 14 Aug 2015 16:38:49 +0900 Subject: [PATCH 201/207] checking if (buffer-file-name) returns non-nil just in case. --- elisp/ghc-check.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el index d9270ba..dad5416 100644 --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -65,7 +65,8 @@ nil does not display errors/warnings. (defun ghc-check-syntax () (interactive) ;; Only check syntax of visible buffers - (when (and (file-exists-p (buffer-file-name)) + (when (and (buffer-file-name) + (file-exists-p (buffer-file-name)) (get-buffer-window (current-buffer) t)) (with-timeout (10 (error "ghc process may have hung or exited with an error")) From 8a0c4be12b000bd4a80894b79246759416b4791f Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 14 Aug 2015 16:47:44 +0900 Subject: [PATCH 202/207] defining ghc-debug-options. --- elisp/ghc-process.el | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 93b63e5..497ecde 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -10,6 +10,9 @@ (require 'ghc-func) +(defvar ghc-debug-options nil) +;; (setq ghc-debug-options '("-v9")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar ghc-process-running nil) @@ -68,7 +71,8 @@ (t cpro))) (defun ghc-start-process (name buf) - (let* ((opts (append '("-b" "\n" "-l" "--line-prefix=O: ,E: ") + (let* ((opts (append ghc-debug-options + '("-b" "\n" "-l" "--line-prefix=O: ,E: ") (ghc-make-ghc-options) '("legacy-interactive"))) (pro (apply 'start-file-process name buf ghc-command opts))) From 9cff067a27f8dc8b735d6fd741a62c2c498fa9c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 09:47:45 +0200 Subject: [PATCH 203/207] Catch errors in legacy-interactive loop --- src/GHCMod.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 094e0de..46d858d 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -411,7 +411,7 @@ legacyInteractiveLoop symdbreq world = do cmd = dropWhileEnd isSpace cmd' args = dropWhileEnd isSpace `map` args' - res <- case dropWhileEnd isSpace cmd of + res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of "check" -> checkSyntaxCmd [arg] "lint" -> lintCmd [arg] "find" -> do @@ -435,6 +435,11 @@ legacyInteractiveLoop symdbreq world = do gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout) legacyInteractiveLoop symdbreq world + where + interactiveHandlers = + [ GHandler $ \e@(FatalError _) -> throw e + , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return "" + ] ghcCommands :: IOish m => [String] -> GhcModT m () ghcCommands [] = fatalError "No command given (try --help)" From 6248372477cf3ab1a00bfe068abc90d606a750ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 09:50:20 +0200 Subject: [PATCH 204/207] Fix tests for 7.10 --- test/FindSpec.hs | 3 ++- test/TargetSpec.hs | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/test/FindSpec.hs b/test/FindSpec.hs index 55e84df..99fe3aa 100644 --- a/test/FindSpec.hs +++ b/test/FindSpec.hs @@ -1,6 +1,7 @@ module FindSpec where import Language.Haskell.GhcMod.Find +import Control.Monad import Test.Hspec import TestUtils @@ -8,5 +9,5 @@ spec :: Spec spec = do describe "db <- loadSymbolDb" $ do it "lookupSymbol' db \"head\" contains at least `Data.List'" $ do - db <- runD loadSymbolDb + db <- runD $ loadSymbolDb =<< (cradleTempDir `liftM` cradle) lookupSym "head" db `shouldContain` [ModuleString "Data.List"] diff --git a/test/TargetSpec.hs b/test/TargetSpec.hs index 5fc1466..9207b65 100644 --- a/test/TargetSpec.hs +++ b/test/TargetSpec.hs @@ -41,6 +41,6 @@ spec = do it "Works when a module given as path uses CPP" $ do dir <- getCurrentDirectory let srcDirs = [dir "test/data/target/src"] - x <- withLightHscEnv [] $ \env -> runNullLog $ do + x <- withLightHscEnv [] $ \env -> runD $ do resolveModule env srcDirs (Left $ dir "test/data/target/Cpp.hs") liftIO $ x `shouldBe` Just (ModulePath "Cpp" $ dir "test/data/target/Cpp.hs") From 7af35a3850539ccf17be70ad28ed1289c81f9f20 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 14 Aug 2015 17:08:14 +0900 Subject: [PATCH 205/207] fixing doc. --- doc/emacs.piki | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/emacs.piki b/doc/emacs.piki index 31171d5..31643a5 100644 --- a/doc/emacs.piki +++ b/doc/emacs.piki @@ -119,7 +119,7 @@ foo xs = foldr bar id xs bar = (:) |< -C-xC-s highlights the 2nd line. C-c? displays the following: +C-xC-s highlights the 2nd line. M-? displays the following: >| Couldn't match type `[a -> a]' with `a -> a' @@ -139,7 +139,7 @@ foo xs = foldr _bar id xs bar = (:) |< -C-c? displays: +M-? displays: >| Found hole `_bar' with type: (a -> a) -> (a -> a) -> a -> a From 585a9ef425593f6dbb72a1f07a825d86167eb8d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 10:28:32 +0200 Subject: [PATCH 206/207] Fix `doc` in non-cabal projects ..man those non-cabal projects are really getting me down. Who uses those anwayways ;) --- Language/Haskell/GhcMod/CabalHelper.hs | 36 ++++++++++++-------------- Language/Haskell/GhcMod/GhcPkg.hs | 14 +++++++--- Language/Haskell/GhcMod/PkgDoc.hs | 1 - test/CabalHelperSpec.hs | 2 +- test/GhcPkgSpec.hs | 30 +++++++++++++++++++++ 5 files changed, 57 insertions(+), 26 deletions(-) create mode 100644 test/GhcPkgSpec.hs diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index c9076bb..ef6f501 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -19,7 +19,8 @@ module Language.Haskell.GhcMod.CabalHelper #ifndef SPEC ( getComponents , getGhcMergedPkgOptions - , getPackageDbStack + , getCabalPackageDbStack + , getCustomPkgDbStack , prepareCabalHelper ) #endif @@ -60,25 +61,8 @@ getGhcMergedPkgOptions = chCached Cached { return ([setupConfigPath], opts) } -parseCustomPackageDb :: String -> [GhcPkgDb] -parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src - where - parsePkgDb "global" = GlobalDb - parsePkgDb "user" = UserDb - parsePkgDb s = PackageDb s - -getCustomPkgDbStack :: (IOish m, GmEnv m) => m (Maybe [GhcPkgDb]) -getCustomPkgDbStack = do - mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle - return $ parseCustomPackageDb <$> mCusPkgDbFile - -getPackageDbStack :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb] -getPackageDbStack = do - mCusPkgStack <- getCustomPkgDbStack - flip fromMaybe mCusPkgStack <$> getPackageDbStack' - -getPackageDbStack' :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb] -getPackageDbStack' = chCached Cached { +getCabalPackageDbStack :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb] +getCabalPackageDbStack = chCached Cached { cacheLens = Just (lGmcPackageDbStack . lGmCaches), cacheFile = pkgDbStackCacheFile, cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do @@ -136,6 +120,18 @@ prepareCabalHelper = do when (cradleProjectType crdl == CabalProject) $ withCabal $ liftIO $ prepare readProc projdir distdir +parseCustomPackageDb :: String -> [GhcPkgDb] +parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src + where + parsePkgDb "global" = GlobalDb + parsePkgDb "user" = UserDb + parsePkgDb s = PackageDb s + +getCustomPkgDbStack :: (IOish m, GmEnv m) => m (Maybe [GhcPkgDb]) +getCustomPkgDbStack = do + mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle + return $ parseCustomPackageDb <$> mCusPkgDbFile + withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a withCabal action = do crdl <- cradle diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index 2908c82..f6c281b 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -4,6 +4,7 @@ module Language.Haskell.GhcMod.GhcPkg ( , ghcPkgDbStackOpts , ghcDbStackOpts , ghcDbOpt + , getPackageDbStack , getPackageCachePaths ) where @@ -58,18 +59,23 @@ ghcDbOpt (PackageDb pkgDb) ---------------------------------------------------------------- -getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath] -getPackageCachePaths sysPkgCfg = do +getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb] +getPackageDbStack = do crdl <- cradle - pkgDbStack <- case cradleProjectType crdl of + mCusPkgStack <- getCustomPkgDbStack + stack <- case cradleProjectType crdl of PlainProject -> return [GlobalDb, UserDb] SandboxProject -> do Just db <- liftIO $ getSandboxDb $ cradleRootDir crdl return $ [GlobalDb, db] CabalProject -> - getPackageDbStack + getCabalPackageDbStack + return $ fromMaybe stack mCusPkgStack +getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath] +getPackageCachePaths sysPkgCfg = do + pkgDbStack <- getPackageDbStack catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack -- TODO: use PkgConfRef diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs index ddc4a06..b469f87 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ b/Language/Haskell/GhcMod/PkgDoc.hs @@ -4,7 +4,6 @@ import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.CabalHelper import Control.Applicative import Prelude diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs index 8e4ba64..42211d8 100644 --- a/test/CabalHelperSpec.hs +++ b/test/CabalHelperSpec.hs @@ -91,6 +91,6 @@ spec = do (s, s') <- runD $ do Just stack <- getCustomPkgDbStack withCabal $ do - stack' <- getPackageDbStack' + stack' <- getCabalPackageDbStack return (stack, stack') s' `shouldBe` s diff --git a/test/GhcPkgSpec.hs b/test/GhcPkgSpec.hs new file mode 100644 index 0000000..6f93404 --- /dev/null +++ b/test/GhcPkgSpec.hs @@ -0,0 +1,30 @@ +module GhcPkgSpec where + +import Control.Arrow +import Control.Applicative +import Distribution.Helper +import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.CabalHelper +import Language.Haskell.GhcMod.Error +import Test.Hspec +import System.Directory +import System.FilePath +import System.Process (readProcess, system) + +import Dir +import TestUtils +import Data.List + +spec :: Spec +spec = do + describe "getPackageDbStack'" $ do + it "fixes out of sync custom pkg-db stack" $ do + withDirectory_ "test/data/custom-cradle" $ do + _ <- system "cabal configure" + (s, s') <- runD $ do + Just stack <- getCustomPkgDbStack + withCabal $ do + stack' <- getPackageDbStack + return (stack, stack') + s' `shouldBe` s From 97124afc4cfaa132ef5ed69b166416c1260cdea2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 14 Aug 2015 10:36:33 +0200 Subject: [PATCH 207/207] Bump version to 5.3.0.0 --- elisp/ghc.el | 2 +- ghc-mod.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/elisp/ghc.el b/elisp/ghc.el index e103f4a..a555c47 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -28,7 +28,7 @@ (< emacs-minor-version minor))) (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "0") +(defconst ghc-version "5.3.0.0") ;; (eval-when-compile ;; (require 'haskell-mode)) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 6f055e7..40cdde3 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 0 +Version: 5.3.0.0 Author: Kazu Yamamoto , Daniel Gröber , Alejandro Serrano