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] 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 }