hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Refactoring to use cabal-helper-wrapper

Browse Source 
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`.
This commit is contained in:
Daniel Gröber 2015-03-03 21:12:43 +01:00
parent 7438539ca5
commit 82bb0090c0
43 changed files with 1951 additions and 1844 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Language/Haskell/GhcMod.hs
View File

@ -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

70
Language/Haskell/GhcMod/Browse.hs
View File

@ -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

144
Language/Haskell/GhcMod/CabalApi.hs
View File

@ -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

35
Language/Haskell/GhcMod/CabalConfig.hs
View File

@ -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))

45
Language/Haskell/GhcMod/CabalConfig/Cabal16.hs
View File

@ -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)

58
Language/Haskell/GhcMod/CabalConfig/Cabal18.hs
View File

@ -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)

73
Language/Haskell/GhcMod/CabalConfig/Cabal21.hs
View File

@ -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)

107
Language/Haskell/GhcMod/CabalConfig/Cabal22.hs
View File

@ -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)

223
Language/Haskell/GhcMod/CabalConfig/Extract.hs
View File

@ -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)

49
Language/Haskell/GhcMod/CabalConfig/Ghc710.hs
View File

@ -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

104
Language/Haskell/GhcMod/CabalHelper.hs Normal file
View File

@ -0,0 +1,104 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- 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 <http://www.gnu.org/licenses/>.
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

57
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -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
splits file lineNo colNo =
runGmLoadedT' [Left file] deferErrors $ ghandle handler $ do
opt <- options
modSum <- Gap.fileModSummary file
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
text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
getTyCons dflag style varName varT)
return (fourInts bndLoc, text)
return (fourInts bndLoc, t)
(TySplitInfo varName bndLoc (varLoc,varT)) -> do
let varName' = showName dflag style varName -- Convert name to string
text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
getTyCons dflag style varName varT)
return (fourInts bndLoc, text)
handler (SomeException _) = emptyResult =<< options
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 =

30
Language/Haskell/GhcMod/Check.hs
View File

@ -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 ())

4
Language/Haskell/GhcMod/Convert.hs
View File

@ -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

74
Language/Haskell/GhcMod/Cradle.hs
View File

@ -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

85
Language/Haskell/GhcMod/Debug.hs
View File

@ -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.

12
Language/Haskell/GhcMod/Doc.hs
View File

@ -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

32
Language/Haskell/GhcMod/DynFlags.hs
View File

@ -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

163
Language/Haskell/GhcMod/Error.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-}
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
@ -14,64 +13,47 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# 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 $ "<command line>: " ++ 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

43
Language/Haskell/GhcMod/FillSig.hs
View File

@ -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
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
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))
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,6 +350,7 @@ refine file lineNo colNo expr = ghandle handler body
text = initialHead1 expr iArgs (infinitePrefixSupply name)
in (fourInts loc, doParen paren text)
where
handler (SomeException _) = emptyResult =<< options
-- Look for the variable in the specified position
@ -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,7 +428,7 @@ 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))
where
handler (SomeException _) = emptyResult =<< options
-- Functions we do not want in completions

14
Language/Haskell/GhcMod/Find.hs
View File

@ -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

23
Language/Haskell/GhcMod/GHCChoice.hs
View File

@ -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

109
Language/Haskell/GhcMod/Gap.hs
View File

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

31
Language/Haskell/GhcMod/GhcPkg.hs
View File

@ -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)

270
Language/Haskell/GhcMod/HomeModuleGraph.hs Normal file
View File

@ -0,0 +1,270 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- 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 <http://www.gnu.org/licenses/>.
{-# 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)

42
Language/Haskell/GhcMod/Info.hs
View File

@ -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,14 +53,17 @@ 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
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)]

19
Language/Haskell/GhcMod/Internal.hs
View File

@ -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

116
Language/Haskell/GhcMod/Logger.hs
View File

@ -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

48
Language/Haskell/GhcMod/Logging.hs
View File

@ -1,4 +1,3 @@
module Language.Haskell.GhcMod.Logging where
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
@ -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 <http://www.gnu.org/licenses/>.
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)])

7
Language/Haskell/GhcMod/Modules.hs
View File

@ -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

232
Language/Haskell/GhcMod/Monad.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE CPP, RecordWildCards #-}
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
@ -14,166 +13,74 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# 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
withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
withCradle cradledir f =
gbracket (liftIO $ findCradle' cradledir) (liftIO . cleanupCradle) f
withGhcModEnv :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
withGhcModEnv dir opt f = withCradle dir (withGhcModEnv' opt f)
withGhcModEnv' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a
withGhcModEnv' opt f crdl = do
olddir <- liftIO getCurrentDirectory
gbracket_ (liftIO $ setCurrentDirectory $ cradleRootDir crdl)
(liftIO $ setCurrentDirectory olddir)
(f $ GhcModEnv opt crdl)
where
mCabalFile = cradleCabalFile c
cabal = isJust mCabalFile
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
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
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'' r s a = do
flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGhcModT a) s

424
Language/Haskell/GhcMod/Monad/Types.hs
View File

@ -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

106
Language/Haskell/GhcMod/PathsAndFiles.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns, TupleSections #-}
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
@ -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"

4
Language/Haskell/GhcMod/PkgDoc.hs
View File

@ -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

64
Language/Haskell/GhcMod/Pretty.hs Normal file
View File

@ -0,0 +1,64 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- 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 <http://www.gnu.org/licenses/>.
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

23
Language/Haskell/GhcMod/SrcUtils.hs
View File

@ -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

333
Language/Haskell/GhcMod/Target.hs
View File

@ -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 <dxld ÄT darkboxed DOT org>
--
@ -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 <http://www.gnu.org/licenses/>.
{-# 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

186
Language/Haskell/GhcMod/Types.hs
View File

@ -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)

140
Language/Haskell/GhcMod/Utils.hs
View File

@ -15,28 +15,28 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# 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

46
Language/Haskell/GhcMod/World.hs
View File

@ -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

36
Utils.hs Normal file
View File

@ -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

63
ghc-mod.cabal
View File

@ -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.*)

9
src/GHCMod.hs
View File

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