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

Use cabal-helper to support Cabal >= 1.22 with any version of ghc

This commit is contained in:
Daniel Gröber 2015-02-07 23:55:57 +01:00
parent 844bdea3db
commit ef96b926c7
15 changed files with 789 additions and 481 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -13,6 +13,7 @@ import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, mkGHCCompilerId)
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Logging
import MonadUtils (liftIO)
import Control.Applicative ((<$>))
@ -36,14 +37,15 @@ import System.FilePath ((</>))
----------------------------------------------------------------
-- | Getting necessary 'CompilerOptions' from three information sources.
getCompilerOptions :: (IOish m, MonadError GhcModError m)
getCompilerOptions :: (IOish m, GmError m, GmLog m)
=> [GHCOption]
-> Cradle
-> CabalConfig
-> PackageDescription
-> m CompilerOptions
getCompilerOptions ghcopts cradle pkgDesc = do
getCompilerOptions ghcopts cradle config pkgDesc = do
gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos
depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc)
let depPkgs = cabalConfigDependencies config (C.packageId pkgDesc)
return $ CompilerOptions gopts idirs depPkgs
where
wdir = cradleCurrentDir cradle
@ -67,14 +69,14 @@ includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])
----------------------------------------------------------------
-- | Parse a cabal file and return a 'PackageDescription'.
parseCabalFile :: (IOish m, MonadError GhcModError m)
=> Cradle
parseCabalFile :: (IOish m, GmError m, GmLog m)
=> CabalConfig
-> FilePath
-> m PackageDescription
parseCabalFile cradle file = do
parseCabalFile config file = do
cid <- mkGHCCompilerId <$> liftIO getGHCVersion
epgd <- liftIO $ readPackageDescription silent file
flags <- cabalConfigFlags cradle
flags <- cabalConfigFlags config
case toPkgDesc cid flags epgd of
Left deps -> fail $ show deps ++ " are not installed"
Right (pd,_) -> if nullPkg pd

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

@ -4,39 +4,32 @@
-- 'LocalBuildInfo' (@dist/setup-config@) for different version combinations of
-- Cabal and GHC.
module Language.Haskell.GhcMod.CabalConfig (
cabalConfigDependencies
CabalConfig
, cabalGetConfig
, cabalConfigDependencies
, cabalConfigFlags
) where
import Control.Applicative
import Distribution.Package (PackageIdentifier)
import Distribution.PackageDescription (FlagAssignment)
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Error
#if __GLASGOW_HASKELL__ >= 710
import Language.Haskell.GhcMod.CabalConfig.Ghc710
#else
import Language.Haskell.GhcMod.CabalConfig.PreGhc710
#endif
import Language.Haskell.GhcMod.CabalConfig.Extract
cabalGetConfig :: (IOish m, GmError m) => Cradle -> m CabalConfig
cabalGetConfig = getConfig
-- | Get list of 'Package's needed by all components of the current package
cabalConfigDependencies :: (IOish m, MonadError GhcModError m)
=> Cradle
-> PackageIdentifier
-> m [Package]
cabalConfigDependencies cradle thisPkg =
configDependencies thisPkg <$> getConfig cradle
cabalConfigDependencies :: CabalConfig -> PackageIdentifier -> [Package]
cabalConfigDependencies config thisPkg =
configDependencies thisPkg config
-- | Get the flag assignment from the local build info of the given cradle
cabalConfigFlags :: (IOish m, MonadError GhcModError m)
=> Cradle
-> m FlagAssignment
cabalConfigFlags cradle = do
config <- getConfig cradle
cabalConfigFlags :: (IOish m, GmError m) => CabalConfig -> m FlagAssignment
cabalConfigFlags config = do
case configFlags config of
Right x -> return x
Left msg -> throwError (GMECabalFlags (GMEString msg))

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

@ -0,0 +1,107 @@
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
-- Copyright : Isaac Jones 2003-2004
-- Copyright : (c) The University of Glasgow 2004
-- Copyright : Duncan Coutts 2008
{- All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Isaac Jones nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-- | ComponentLocalBuildInfo for Cabal >= 1.22
module Language.Haskell.GhcMod.CabalConfig.Cabal22 (
ComponentLocalBuildInfo
, PackageIdentifier(..)
, PackageName(..)
, componentPackageDeps
, componentLibraries
) where
import Distribution.Package (InstalledPackageId)
import Data.Version (Version)
import Data.Map (Map)
data LibraryName = LibraryName String
deriving (Read, Show)
newtype PackageName = PackageName { unPackageName :: String }
deriving (Read, Show, Ord, Eq)
data PackageIdentifier
= PackageIdentifier {
pkgName :: PackageName,
pkgVersion :: Version
}
deriving (Read, Show)
type PackageId = PackageIdentifier
newtype ModuleName = ModuleName [String]
deriving (Read, Show)
data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)]
deriving (Read, Show)
data OriginalModule
= OriginalModule {
originalPackageId :: InstalledPackageId,
originalModuleName :: ModuleName
}
deriving (Read, Show)
data ExposedModule
= ExposedModule {
exposedName :: ModuleName,
exposedReexport :: Maybe OriginalModule,
exposedSignature :: Maybe OriginalModule -- This field is unused for now.
}
deriving (Read, Show)
data ComponentLocalBuildInfo
= LibComponentLocalBuildInfo {
-- | Resolved internal and external package dependencies for this component.
-- The 'BuildInfo' specifies a set of build dependencies that must be
-- satisfied in terms of version ranges. This field fixes those dependencies
-- to the specific versions available on this machine for this compiler.
componentPackageDeps :: [(InstalledPackageId, PackageId)],
componentExposedModules :: [ExposedModule],
componentPackageRenaming :: Map PackageName ModuleRenaming,
componentLibraries :: [LibraryName]
}
| ExeComponentLocalBuildInfo {
componentPackageDeps :: [(InstalledPackageId, PackageId)],
componentPackageRenaming :: Map PackageName ModuleRenaming
}
| TestComponentLocalBuildInfo {
componentPackageDeps :: [(InstalledPackageId, PackageId)],
componentPackageRenaming :: Map PackageName ModuleRenaming
}
| BenchComponentLocalBuildInfo {
componentPackageDeps :: [(InstalledPackageId, PackageId)],
componentPackageRenaming :: Map PackageName ModuleRenaming
}
deriving (Read, Show)

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

@ -0,0 +1,223 @@
{-# LANGUAGE RecordWildCards, CPP, OverloadedStrings #-}
-- | This module facilitates extracting information from Cabal's on-disk
-- 'LocalBuildInfo' (@dist/setup-config@).
module Language.Haskell.GhcMod.CabalConfig.Extract (
CabalConfig
, configDependencies
, configFlags
, getConfig
) where
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Read
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
import qualified Language.Haskell.GhcMod.CabalConfig.Cabal16 as C16
import qualified Language.Haskell.GhcMod.CabalConfig.Cabal18 as C18
import qualified Language.Haskell.GhcMod.CabalConfig.Cabal22 as C22
#ifndef MIN_VERSION_mtl
#define MIN_VERSION_mtl(x,y,z) 1
#endif
import Control.Applicative ((<$>))
import Control.Monad (void, mplus, when)
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except ()
#else
import Control.Monad.Error ()
#endif
import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)
import Data.Version
import Distribution.Package (InstalledPackageId(..)
, PackageIdentifier(..)
, PackageName(..))
import Distribution.PackageDescription (FlagAssignment)
import Distribution.Simple.LocalBuildInfo (ComponentName)
import MonadUtils (liftIO)
import Text.ParserCombinators.ReadP
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
----------------------------------------------------------------
-- | 'Show'ed cabal 'LocalBuildInfo' string
newtype CabalConfig = CabalConfig { unCabalConfig :: String }
-- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't
-- exist run @cabal configure@ i.e. configure with default options like @cabal
-- build@ would do.
getConfig :: (IOish m, GmError m) => Cradle -> m CabalConfig
getConfig crdl = do
liftIO (getCurrentWorld crdl) >>= \world ->
when (isSetupConfigOutOfDate world) configure
cfg <- liftIO (BS.readFile file) `tryFix` \_ ->
configure `modifyError'` GMECabalConfigure
liftIO (getCurrentWorld crdl) >>= \world ->
decodeConfig crdl world file cfg
where
file = setupConfigFile crdl
prjDir = cradleRootDir crdl
configure :: (IOish m, GmError m) => m ()
configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
decodeConfig :: (IOish m, GmError m)
=> Cradle -> World -> FilePath -> ByteString -> m CabalConfig
decodeConfig _crdl _world file bs = CabalConfig <$> gen
-- if cacheOutdated world
-- then
-- gmLog $ "Regenerating pretty setup-config cache: " ++ prettyConfigCache
-- liftIO $ writeFile prettyConfigCache cfg
-- else CabalConfig <$> liftIO (readFile prettyConfigCache)
where
-- cacheOutdated World {..} =
-- case (worldCabalConfig, worldPrettyCabalConfigCache) of
-- (Nothing, _) -> error "decodeConfig: setup-config does not exist."
-- (Just _, Nothing) -> True
-- (Just s, Just p) -> s > p
gen = case BS8.lines bs of
header:_ -> do
((_,cabalVer), _) <- parseHeader header
if cabalVer >= (Version [1,22] [])
then prettyPrintBinaryConfig file
else return $ bsToStr bs
[] -> throwError $ GMECabalStateFile GMConfigStateFileNoHeader
prettyPrintBinaryConfig :: (IOish m, GmError m)
=> String -> m String
prettyPrintBinaryConfig file = do
exe <- liftIO $ findLibexecExe "ghc-mod-cabal"
slbi <- readProcess' exe ["print-setup-config", file]
return slbi
parseHeader :: GmError m
=> ByteString -> m ((ByteString, Version), (ByteString, Version))
parseHeader header = case BS8.words header of
["Saved", "package", "config", "for", _pkgId , "written", "by", cabalId, "using", compId] -> modifyError (\_ -> GMECabalStateFile GMConfigStateFileBadHeader) $ do
cabalId' <- parsePkgId cabalId
compId' <- parsePkgId compId
return (cabalId', compId')
_ -> throwError $ GMECabalStateFile GMConfigStateFileNoHeader
parsePkgId :: (Error e, MonadError e m) => ByteString -> m (ByteString, Version)
parsePkgId bs =
case BS8.split '-' bs of
[pkg, vers] -> return (pkg, parseVer vers)
_ -> throwError noMsg
where
parseVer vers =
let (ver,""):[] =
filter ((=="") . snd) $ readP_to_S parseVersion (bsToStr vers)
in ver
bsToStr :: ByteString -> String
bsToStr = T.unpack . T.decodeUtf8
-- strToBs :: String -> ByteString
-- strToBs = T.encodeUtf8 . T.pack
-- | Extract list of depencenies for all components from 'CabalConfig'
configDependencies :: PackageIdentifier -> CabalConfig -> [Package]
configDependencies thisPkg config = map fromInstalledPackageId deps
where
deps :: [InstalledPackageId]
deps = case deps16 `mplus` deps18 `mplus` deps22 of
Right ps -> ps
Left msg -> error msg
-- True if this dependency is an internal one (depends on the library
-- defined in the same package).
internal pkgid = pkgid == thisPkg
-- Cabal >= 1.22
deps22 :: Either String [InstalledPackageId]
deps22 =
map fst
<$> filterInternal22
<$> (readEither =<< extractField (unCabalConfig config) "componentsConfigs")
filterInternal22
:: [(ComponentName, C22.ComponentLocalBuildInfo, [ComponentName])]
-> [(InstalledPackageId, C22.PackageIdentifier)]
filterInternal22 ccfg = [ (ipkgid, pkgid)
| (_,clbi,_) <- ccfg
, (ipkgid, pkgid) <- C22.componentPackageDeps clbi
, not (internal . packageIdentifierFrom22 $ pkgid) ]
packageIdentifierFrom22 :: C22.PackageIdentifier -> PackageIdentifier
packageIdentifierFrom22 (C22.PackageIdentifier (C22.PackageName myName) myVersion) =
PackageIdentifier (PackageName myName) myVersion
-- Cabal >= 1.18 && < 1.20
deps18 :: Either String [InstalledPackageId]
deps18 =
map fst
<$> filterInternal
<$> (readEither =<< extractField (unCabalConfig config) "componentsConfigs")
filterInternal
:: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])]
-> [(InstalledPackageId, PackageIdentifier)]
filterInternal ccfg = [ (ipkgid, pkgid)
| (_,clbi,_) <- ccfg
, (ipkgid, pkgid) <- C18.componentPackageDeps clbi
, not (internal pkgid) ]
-- Cabal 1.16 and below
deps16 :: Either String [InstalledPackageId]
deps16 = map fst <$> filter (not . internal . snd) . nub <$> do
cbi <- concat <$> sequence [ extract "executableConfigs"
, extract "testSuiteConfigs"
, extract "benchmarkConfigs" ]
:: Either String [(String, C16.ComponentLocalBuildInfo)]
return $ maybe [] C16.componentPackageDeps libraryConfig
++ concatMap (C16.componentPackageDeps . snd) cbi
where
libraryConfig :: Maybe C16.ComponentLocalBuildInfo
libraryConfig = do
field <- find ("libraryConfig" `isPrefixOf`) (tails $ unCabalConfig config)
clbi <- stripPrefix " = " field
if "Nothing" `isPrefixOf` clbi
then Nothing
else case readMaybe =<< stripPrefix "Just " clbi of
Just x -> x
Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi)
extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)]
extract field = readConfigs field <$> extractField (unCabalConfig config) field
readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)]
readConfigs f s = case readEither s of
Right x -> x
Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")"
-- | Extract the cabal flags from the 'CabalConfig'
configFlags :: CabalConfig -> Either String FlagAssignment
configFlags (CabalConfig config) = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags"
-- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable
-- error message with lots of context on failure.
extractField :: String -> String -> Either String String
extractField content field =
case extractParens <$> find (field `isPrefixOf`) (tails content) of
Just f -> Right f
Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` content)

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

@ -17,6 +17,7 @@ import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
@ -24,19 +25,18 @@ import Language.Haskell.GhcMod.World
-- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't
-- exist run @cabal configure@ i.e. configure with default options like @cabal
-- build@ would do.
getConfig :: (IOish m, MonadError GhcModError m)
getConfig :: (IOish m, GmError m)
=> Cradle
-> m LocalBuildInfo
getConfig cradle = do
outOfDate <- liftIO $ isSetupConfigOutOfDate cradle
when outOfDate configure
getConfig cradle = liftIO (getCurrentWorld cradle) >>= \world -> do
when (isSetupConfigOutOfDate world) configure
liftIO (getConfigStateFile file) `tryFix` \_ ->
configure `modifyError'` GMECabalConfigure
where
file = setupConfigFile cradle
prjDir = cradleRootDir cradle
configure :: (IOish m, MonadError GhcModError m) => m ()
configure :: (IOish m, GmError m) => m ()
configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
configDependencies :: a -> LocalBuildInfo -> [Package]

154
Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs
View File

@ -1,154 +0,0 @@
{-# LANGUAGE RecordWildCards, CPP #-}
-- | This module facilitates extracting information from Cabal's on-disk
-- 'LocalBuildInfo' (@dist/setup-config@).
module Language.Haskell.GhcMod.CabalConfig.PreGhc710 (
configDependencies
, configFlags
, getConfig
) where
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Read
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
import qualified Language.Haskell.GhcMod.CabalConfig.Cabal16 as C16
import qualified Language.Haskell.GhcMod.CabalConfig.Cabal18 as C18
import qualified Language.Haskell.GhcMod.CabalConfig.Cabal21 as C21
#ifndef MIN_VERSION_mtl
#define MIN_VERSION_mtl(x,y,z) 1
#endif
import Control.Applicative ((<$>))
import Control.Monad (void, mplus, when)
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except ()
#else
import Control.Monad.Error ()
#endif
import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)
import Distribution.Package (InstalledPackageId(..)
, PackageIdentifier(..)
, PackageName(..))
import Distribution.PackageDescription (FlagAssignment)
import Distribution.Simple.LocalBuildInfo (ComponentName)
import MonadUtils (liftIO)
----------------------------------------------------------------
-- | 'Show'ed cabal 'LocalBuildInfo' string
type CabalConfig = String
-- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't
-- exist run @cabal configure@ i.e. configure with default options like @cabal
-- build@ would do.
getConfig :: (IOish m, MonadError GhcModError m)
=> Cradle
-> m CabalConfig
getConfig cradle = do
outOfDate <- liftIO $ isSetupConfigOutOfDate cradle
when outOfDate configure
liftIO (readFile file) `tryFix` \_ ->
configure `modifyError'` GMECabalConfigure
where
file = setupConfigFile cradle
prjDir = cradleRootDir cradle
configure :: (IOish m, MonadError GhcModError m) => m ()
configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
-- | Extract list of depencenies for all components from 'CabalConfig'
configDependencies :: PackageIdentifier -> CabalConfig -> [Package]
configDependencies thisPkg config = map fromInstalledPackageId deps
where
deps :: [InstalledPackageId]
deps = case deps21 `mplus` deps18 `mplus` deps16 of
Right ps -> ps
Left msg -> error msg
-- True if this dependency is an internal one (depends on the library
-- defined in the same package).
internal pkgid = pkgid == thisPkg
-- Cabal >= 1.21
deps21 :: Either String [InstalledPackageId]
deps21 =
map fst
<$> filterInternal21
<$> (readEither =<< extractField config "componentsConfigs")
filterInternal21
:: [(ComponentName, C21.ComponentLocalBuildInfo, [ComponentName])]
-> [(InstalledPackageId, C21.PackageIdentifier)]
filterInternal21 ccfg = [ (ipkgid, pkgid)
| (_,clbi,_) <- ccfg
, (ipkgid, pkgid) <- C21.componentPackageDeps clbi
, not (internal . packageIdentifierFrom21 $ pkgid) ]
packageIdentifierFrom21 :: C21.PackageIdentifier -> PackageIdentifier
packageIdentifierFrom21 (C21.PackageIdentifier (C21.PackageName myName) myVersion) =
PackageIdentifier (PackageName myName) myVersion
-- Cabal >= 1.18 && < 1.21
deps18 :: Either String [InstalledPackageId]
deps18 =
map fst
<$> filterInternal
<$> (readEither =<< extractField config "componentsConfigs")
filterInternal
:: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])]
-> [(InstalledPackageId, PackageIdentifier)]
filterInternal ccfg = [ (ipkgid, pkgid)
| (_,clbi,_) <- ccfg
, (ipkgid, pkgid) <- C18.componentPackageDeps clbi
, not (internal pkgid) ]
-- Cabal 1.16 and below
deps16 :: Either String [InstalledPackageId]
deps16 = map fst <$> filter (not . internal . snd) . nub <$> do
cbi <- concat <$> sequence [ extract "executableConfigs"
, extract "testSuiteConfigs"
, extract "benchmarkConfigs" ]
:: Either String [(String, C16.ComponentLocalBuildInfo)]
return $ maybe [] C16.componentPackageDeps libraryConfig
++ concatMap (C16.componentPackageDeps . snd) cbi
where
libraryConfig :: Maybe C16.ComponentLocalBuildInfo
libraryConfig = do
field <- find ("libraryConfig" `isPrefixOf`) (tails config)
clbi <- stripPrefix " = " field
if "Nothing" `isPrefixOf` clbi
then Nothing
else case readMaybe =<< stripPrefix "Just " clbi of
Just x -> x
Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi)
extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)]
extract field = readConfigs field <$> extractField config field
readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)]
readConfigs f s = case readEither s of
Right x -> x
Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")"
-- | Extract the cabal flags from the 'CabalConfig'
configFlags :: CabalConfig -> Either String FlagAssignment
configFlags config = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags"
-- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable
-- error message with lots of context on failure.
extractField :: CabalConfig -> String -> Either String String
extractField config field =
case extractParens <$> find (field `isPrefixOf`) (tails config) of
Just f -> Right f
Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config)

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

@ -6,6 +6,7 @@ import Data.Maybe (isJust, fromJust)
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.CabalConfig
import Language.Haskell.GhcMod.Internal
----------------------------------------------------------------
@ -30,9 +31,10 @@ debugInfo = cradle >>= \c -> convert' =<< do
where
simpleCompilerOption = options >>= \op ->
return $ CompilerOptions (ghcUserOptions op) [] []
fromCabalFile c = options >>= \opts -> do
pkgDesc <- parseCabalFile c $ fromJust $ cradleCabalFile c
getCompilerOptions (ghcUserOptions opts) c pkgDesc
fromCabalFile crdl = options >>= \opts -> do
config <- cabalGetConfig crdl
pkgDesc <- parseCabalFile config $ fromJust $ cradleCabalFile crdl
getCompilerOptions (ghcUserOptions opts) crdl config pkgDesc
----------------------------------------------------------------

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

@ -1,6 +1,8 @@
{-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-}
module Language.Haskell.GhcMod.Error (
GhcModError(..)
, GMConfigStateFileError(..)
, GmError
, gmeDoc
, modifyError
, modifyError'
@ -15,26 +17,81 @@ import Data.Typeable
import Exception
import Text.PrettyPrint
type GmError m = MonadError GhcModError m
data GhcModError = GMENoMsg
-- ^ Unknown error
| GMEString String
-- ^ Some Error with a message. These are produced mostly by
-- 'fail' calls on GhcModT.
| GMEIOException IOException
-- ^ IOExceptions captured by GhcModT's MonadIO instance
| GMECabalConfigure GhcModError
-- ^ Configuring a cabal project failed.
| GMECabalFlags GhcModError
-- ^ Retrieval of the cabal configuration flags failed.
| GMEProcess [String] GhcModError
-- ^ Launching an operating system process failed. The first
-- field is the command.
| GMENoCabalFile
-- ^ No cabal file found.
| GMETooManyCabalFiles [FilePath]
-- ^ Too many cabal files found.
| GMECabalStateFile GMConfigStateFileError
-- ^ Reading Cabal's state configuration file falied somehow.
deriving (Eq,Show,Typeable)
data GMConfigStateFileError
= GMConfigStateFileNoHeader
| GMConfigStateFileBadHeader
| GMConfigStateFileNoParse
| GMConfigStateFileMissing
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
deriving (Eq, Show, Read, Typeable)
gmCsfeDoc :: GMConfigStateFileError -> Doc
gmCsfeDoc GMConfigStateFileNoHeader = text $
"Saved package config file header is missing. "
++ "Try re-running the 'configure' command."
gmCsfeDoc GMConfigStateFileBadHeader = text $
"Saved package config file header is corrupt. "
++ "Try re-running the 'configure' command."
gmCsfeDoc GMConfigStateFileNoParse = text $
"Saved package config file body is corrupt. "
++ "Try re-running the 'configure' command."
gmCsfeDoc GMConfigStateFileMissing = text $
"Run the 'configure' command first."
-- gmCsfeDoc (ConfigStateFileBadVersion oldCabal oldCompiler _) = text $
-- "You need to re-run the 'configure' command. "
-- ++ "The version of Cabal being used has changed (was "
-- ++ display oldCabal ++ ", now "
-- ++ display currentCabalId ++ ")."
-- ++ badCompiler
-- where
-- badCompiler
-- | oldCompiler == currentCompilerId = ""
-- | otherwise =
-- " Additionally the compiler is different (was "
-- ++ display oldCompiler ++ ", now "
-- ++ display currentCompilerId
-- ++ ") which is probably the cause of the problem."
instance Exception GhcModError
instance Error GhcModError where
@ -61,6 +118,9 @@ gmeDoc e = case e of
GMETooManyCabalFiles cfs ->
text $ "Multiple cabal files found. Possible cabal files: \""
++ intercalate "\", \"" cfs ++"\"."
GMECabalStateFile csfe ->
gmCsfeDoc csfe
modifyError :: MonadError e m => (e -> e) -> m a -> m a
modifyError f action = action `catchError` \e -> throwError $ f e

21
Language/Haskell/GhcMod/Logging.hs Normal file
View File

@ -0,0 +1,21 @@
module Language.Haskell.GhcMod.Logging where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Control.Monad.Journal.Class
import Control.Monad.Trans.Class
import System.IO
import MonadUtils
--gmSink :: IOish m => (GhcModLog -> IO ()) -> GhcModT m ()
--gmSink = GhcModT . (lift . lift . sink)
type GmLog m = MonadJournal GhcModLog m
gmJournal :: IOish m => GhcModLog -> GhcModT m ()
gmJournal = GhcModT . lift . lift . journal
gmLog :: (MonadIO m, MonadJournal GhcModLog m) => String -> m ()
gmLog str = liftIO (hPutStrLn stderr str) >> (journal $ GhcModLog [str])

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

@ -1,9 +1,4 @@
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP, RecordWildCards #-}
module Language.Haskell.GhcMod.Monad (
-- * Monad Types
GhcModT
@ -20,41 +15,32 @@ module Language.Haskell.GhcMod.Monad (
, runGhcModT
, runGhcModT'
, hoistGhcModT
-- ** Accessing 'GhcModEnv' and 'GhcModState'
-- ** Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'
, gmsGet
, gmsPut
, gmLog
, options
, cradle
, getCompilerMode
, setCompilerMode
, withOptions
, withTempSession
, overrideGhcUserOptions
-- ** Re-exporting convenient stuff
, liftIO
, module Control.Monad.Reader.Class
, module Control.Monad.Journal.Class
) where
#if __GLASGOW_HASKELL__ < 708
-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different
-- classes before ghc 7.8
#define DIFFERENT_MONADIO 1
-- RWST doen't have a MonadIO instance before ghc 7.8
#define MONADIO_INSTANCES 1
#endif
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.CabalConfig
import qualified Language.Haskell.GhcMod.Gap as Gap
import DynFlags
import GHC
import qualified GHC as G
import GHC.Paths (libdir)
@ -69,154 +55,36 @@ import HscTypes
-- So, RWST automatically becomes an instance of MonadIO.
import MonadUtils
#if DIFFERENT_MONADIO
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.IO.Class
import Data.Monoid (Monoid)
#endif
import Control.Applicative (Alternative)
import Control.Arrow (first)
import Control.Monad (MonadPlus, void)
import Control.Monad (void)
#if !MIN_VERSION_monad_control(1,0,0)
import Control.Monad (liftM)
#endif
import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Base (liftBase)
-- Monad transformer stuff
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
control, liftBaseOp, liftBaseOp_)
import Control.Monad.Trans.Class
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class (MonadWriter)
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Error (ErrorT, runErrorT)
import Control.Monad.Reader (ReaderT, runReaderT)
import Control.Monad.State.Strict (StateT, runStateT)
import Control.Monad.Trans.Journal (JournalT, runJournalT)
#ifdef MONADIO_INSTANCES
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Error (Error(..))
#endif
import Control.Monad.Journal.Class
import Control.Monad.Error (runErrorT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.State.Strict (runStateT)
import Control.Monad.Trans.Journal (runJournalT)
import Data.Maybe (isJust)
import Data.IORef (IORef, readIORef, writeIORef, newIORef)
import Data.IORef
import System.Directory (getCurrentDirectory)
----------------------------------------------------------------
data GhcModEnv = GhcModEnv {
gmGhcSession :: !(IORef HscEnv)
, gmOptions :: Options
, gmCradle :: Cradle
}
type GhcModLog = ()
data GhcModState = GhcModState {
gmCompilerMode :: CompilerMode
} deriving (Eq,Show,Read)
data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
defaultState :: GhcModState
defaultState = GhcModState Simple
----------------------------------------------------------------
-- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT'
-- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that
-- means you can run (almost) all functions from the GHC API on top of 'GhcModT'
-- transparently.
--
-- The inner monad @m@ should have instances for 'MonadIO' and
-- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@
-- monads already have 'MonadBaseControl' 'IO' instances, see the
-- @monad-control@ package.
newtype GhcModT m a = GhcModT {
unGhcModT :: StateT GhcModState
(ErrorT GhcModError
(JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) a
} deriving ( Functor
, Applicative
, Alternative
, Monad
, MonadPlus
#if DIFFERENT_MONADIO
, Control.Monad.IO.Class.MonadIO
#endif
, MonadReader GhcModEnv -- TODO: make MonadReader instance
-- pass-through like MonadState
, MonadWriter w
, MonadError GhcModError
)
instance MonadIO m => MonadIO (GhcModT m) where
liftIO action = do
res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action
case res of
Right a -> return a
Left e | isIOError e ->
throwError $ GMEIOException (fromEx e :: IOError)
Left e | isGhcModError e ->
throwError $ (fromEx e :: GhcModError)
Left e -> throw e
where
fromEx :: Exception e => SomeException -> e
fromEx se = let Just e = fromException se in e
isIOError se =
case fromException se of
Just (_ :: IOError) -> True
Nothing -> False
isGhcModError se =
case fromException se of
Just (_ :: GhcModError) -> True
Nothing -> False
instance MonadTrans (GhcModT) where
lift = GhcModT . lift . lift . lift . lift
instance MonadState s m => MonadState s (GhcModT m) where
get = GhcModT $ lift $ lift $ lift get
put = GhcModT . lift . lift . lift . put
state = GhcModT . lift . lift . lift . state
#if MONADIO_INSTANCES
instance MonadIO m => MonadIO (StateT s m) where
liftIO = lift . liftIO
instance MonadIO m => MonadIO (ReaderT r m) where
liftIO = lift . liftIO
instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where
liftIO = lift . liftIO
instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
liftIO = lift . liftIO
instance MonadIO m => MonadIO (MaybeT m) where
liftIO = lift . liftIO
#endif
----------------------------------------------------------------
-- | Initialize the 'DynFlags' relating to the compilation of a single
-- file or GHC session according to the 'Cradle' and 'Options'
-- provided.
initializeFlagsWithCradle :: (IOish m, GhcMonad m, MonadError GhcModError m)
initializeFlagsWithCradle :: (IOish m, GhcMonad m, GmError m, GmLog m)
=> Options
-> Cradle
-> CabalConfig
-> m ()
initializeFlagsWithCradle opt c
initializeFlagsWithCradle opt c config
| cabal = withCabal
| otherwise = withSandbox
where
@ -228,8 +96,8 @@ initializeFlagsWithCradle opt c
withCabal = do
let Just cabalFile = mCabalFile
pkgDesc <- parseCabalFile c cabalFile
compOpts <- getCompilerOptions ghcopts c pkgDesc
pkgDesc <- parseCabalFile config cabalFile
compOpts <- getCompilerOptions ghcopts c config pkgDesc
initSession CabalPkg opt compOpts
withSandbox = initSession SingleFile opt compOpts
@ -283,8 +151,9 @@ runGhcModT opt action = gbracket newEnv delEnv $ \env -> do
r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do
dflags <- getSessionDynFlags
defaultCleanupHandler dflags $ do
initializeFlagsWithCradle opt (gmCradle env)
action)
config <- cabalGetConfig =<< cradle
initializeFlagsWithCradle opt (gmCradle env) config
action )
return r
where
@ -298,7 +167,7 @@ hoistGhcModT :: IOish m
=> (Either GhcModError a, GhcModLog)
-> GhcModT m a
hoistGhcModT (r,l) = do
GhcModT (lift $ lift $ journal l) >> case r of
gmJournal l >> case r of
Left e -> throwError e
Right a -> return a
@ -328,18 +197,6 @@ withTempSession action = do
liftIO $ writeIORef session savedHscEnv
return a
-- | This is a very ugly workaround don't use it.
overrideGhcUserOptions :: IOish m => ([GHCOption] -> GhcModT m b) -> GhcModT m b
overrideGhcUserOptions action = withTempSession $ do
env <- ask
opt <- options
let ghcOpts = ghcUserOptions opt
opt' = opt { ghcUserOptions = [] }
initializeFlagsWithCradle opt' (gmCradle env)
action ghcOpts
----------------------------------------------------------------
gmeAsk :: IOish m => GhcModT m GhcModEnv
@ -373,113 +230,3 @@ withOptions changeOpt action = local changeEnv action
opt = gmOptions e
----------------------------------------------------------------
instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
liftBase = GhcModT . liftBase
#if MIN_VERSION_monad_control(1,0,0)
instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
type StM (GhcModT m) a =
StM (StateT GhcModState
(ErrorT GhcModError
(JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) ) a
liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
f $ runInBase . unGhcModT
restoreM = GhcModT . restoreM
{-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-}
#else
instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
newtype StM (GhcModT m) a = StGhcMod {
unStGhcMod :: StM (StateT GhcModState
(ErrorT GhcModError
(JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) ) a }
liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
f $ liftM StGhcMod . runInBase . unGhcModT
restoreM = GhcModT . restoreM . unStGhcMod
{-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-}
#endif
-- GHC cannot prove the following instances to be decidable automatically using
-- the FlexibleContexts extension as they violate the second Paterson Condition,
-- namely that: The assertion has fewer constructors and variables (taken
-- together and counting repetitions) than the head. Specifically the
-- @MonadBaseControl IO m@ constraint is causing this violation.
--
-- Proof of termination:
--
-- Assuming all constraints containing the variable `m' exist and are decidable
-- we show termination by manually replacing the current set of constraints with
-- their own set of constraints and show that this, after a finite number of
-- steps, results in the empty set, i.e. not having to check any more
-- constraints.
--
-- We start by setting the constraints to be those immediate constraints of the
-- instance declaration which cannot be proven decidable automatically for the
-- type under consideration.
--
-- @
-- { MonadBaseControl IO m }
-- @
--
-- Classes used:
--
-- * @class MonadBase b m => MonadBaseControl b m@
--
-- @
-- { MonadBase IO m }
-- @
--
-- Classes used:
--
-- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@
--
-- @
-- { Applicative IO, Applicative m, Monad IO, Monad m }
-- @
--
-- Classes used:
--
-- * @class Monad m@
-- * @class Applicative f => Functor f@
--
-- @
-- { Functor m }
-- @
--
-- Classes used:
--
-- * @class Functor f@
--
-- @
-- { }
-- @
-- ∎
instance (Functor m, MonadIO m, MonadBaseControl IO m)
=> GhcMonad (GhcModT m) where
getSession = (liftIO . readIORef) . gmGhcSession =<< ask
setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask
#if __GLASGOW_HASKELL__ >= 706
instance (Functor m, MonadIO m, MonadBaseControl IO m)
=> HasDynFlags (GhcModT m) where
getDynFlags = getSessionDynFlags
#endif
instance (MonadIO m, MonadBaseControl IO m)
=> ExceptionMonad (GhcModT m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r

288
Language/Haskell/GhcMod/Monad/Types.hs Normal file
View File

@ -0,0 +1,288 @@
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad.Types where
#if __GLASGOW_HASKELL__ < 708
-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different
-- classes before ghc 7.8
#define DIFFERENT_MONADIO 1
-- RWST doen't have a MonadIO instance before ghc 7.8
#define MONADIO_INSTANCES 1
#endif
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Error
import GHC
import DynFlags
import GhcMonad hiding (withTempSession)
#if __GLASGOW_HASKELL__ <= 702
import HscTypes
#endif
-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.
-- RWST does not automatically become an instance of MonadIO.
-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.
-- So, RWST automatically becomes an instance of MonadIO.
import MonadUtils
import Control.Applicative (Alternative)
import Control.Monad (MonadPlus)
import Control.Monad.Error (ErrorT)
import Control.Monad.Reader (ReaderT)
import Control.Monad.State.Strict (StateT)
import Control.Monad.Trans.Journal (JournalT)
import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
control, liftBaseOp, liftBaseOp_)
import Control.Monad.Trans.Class
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class (MonadWriter)
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Journal.Class (MonadJournal(..))
#ifdef MONADIO_INSTANCES
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Error (Error(..))
#endif
#if DIFFERENT_MONADIO
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.IO.Class
import Data.Monoid (Monoid)
#endif
#if !MIN_VERSION_monad_control(1,0,0)
import Control.Monad (liftM)
#endif
import Data.Monoid
import Data.IORef
data GhcModEnv = GhcModEnv {
gmGhcSession :: !(IORef HscEnv)
, gmOptions :: Options
, gmCradle :: Cradle
}
data GhcModLog = GhcModLog {
gmLogMessages :: [String]
} deriving (Eq, Show, Read)
instance Monoid GhcModLog where
mempty = GhcModLog mempty
GhcModLog a `mappend` GhcModLog b = GhcModLog (a `mappend` b)
data GhcModState = GhcModState {
gmCompilerMode :: CompilerMode
} deriving (Eq,Show,Read)
data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
defaultState :: GhcModState
defaultState = GhcModState Simple
----------------------------------------------------------------
-- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT'
-- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that
-- means you can run (almost) all functions from the GHC API on top of 'GhcModT'
-- transparently.
--
-- The inner monad @m@ should have instances for 'MonadIO' and
-- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@
-- monads already have 'MonadBaseControl' 'IO' instances, see the
-- @monad-control@ package.
newtype GhcModT m a = GhcModT {
unGhcModT :: StateT GhcModState
(ErrorT GhcModError
(JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) a
} deriving ( Functor
, Applicative
, Alternative
, Monad
, MonadPlus
#if DIFFERENT_MONADIO
, Control.Monad.IO.Class.MonadIO
#endif
, MonadReader GhcModEnv -- TODO: make MonadReader instance
-- pass-through like MonadState
, MonadWriter w
, MonadError GhcModError
)
instance MonadIO m => MonadIO (GhcModT m) where
liftIO action = do
res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action
case res of
Right a -> return a
Left e | isIOError e ->
throwError $ GMEIOException (fromEx e :: IOError)
Left e | isGhcModError e ->
throwError $ (fromEx e :: GhcModError)
Left e -> throw e
where
fromEx :: Exception e => SomeException -> e
fromEx se = let Just e = fromException se in e
isIOError se =
case fromException se of
Just (_ :: IOError) -> True
Nothing -> False
isGhcModError se =
case fromException se of
Just (_ :: GhcModError) -> True
Nothing -> False
instance (Monad m) => MonadJournal GhcModLog (GhcModT m) where
journal !w = GhcModT $ lift $ lift $ (journal w)
history = GhcModT $ lift $ lift $ history
clear = GhcModT $ lift $ lift $ clear
instance MonadTrans GhcModT where
lift = GhcModT . lift . lift . lift . lift
instance MonadState s m => MonadState s (GhcModT m) where
get = GhcModT $ lift $ lift $ lift get
put = GhcModT . lift . lift . lift . put
state = GhcModT . lift . lift . lift . state
#if MONADIO_INSTANCES
instance MonadIO m => MonadIO (StateT s m) where
liftIO = lift . liftIO
instance MonadIO m => MonadIO (ReaderT r m) where
liftIO = lift . liftIO
instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where
liftIO = lift . liftIO
instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
liftIO = lift . liftIO
instance MonadIO m => MonadIO (MaybeT m) where
liftIO = lift . liftIO
#endif
instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
liftBase = GhcModT . liftBase
#if MIN_VERSION_monad_control(1,0,0)
instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
type StM (GhcModT m) a =
StM (StateT GhcModState
(ErrorT GhcModError
(JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) ) a
liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
f $ runInBase . unGhcModT
restoreM = GhcModT . restoreM
{-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-}
#else
instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
newtype StM (GhcModT m) a = StGhcMod {
unStGhcMod :: StM (StateT GhcModState
(ErrorT GhcModError
(JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) ) a }
liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
f $ liftM StGhcMod . runInBase . unGhcModT
restoreM = GhcModT . restoreM . unStGhcMod
{-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-}
#endif
-- GHC cannot prove the following instances to be decidable automatically using
-- the FlexibleContexts extension as they violate the second Paterson Condition,
-- namely that: The assertion has fewer constructors and variables (taken
-- together and counting repetitions) than the head. Specifically the
-- @MonadBaseControl IO m@ constraint is causing this violation.
--
-- Proof of termination:
--
-- Assuming all constraints containing the variable `m' exist and are decidable
-- we show termination by manually replacing the current set of constraints with
-- their own set of constraints and show that this, after a finite number of
-- steps, results in the empty set, i.e. not having to check any more
-- constraints.
--
-- We start by setting the constraints to be those immediate constraints of the
-- instance declaration which cannot be proven decidable automatically for the
-- type under consideration.
--
-- @
-- { MonadBaseControl IO m }
-- @
--
-- Classes used:
--
-- * @class MonadBase b m => MonadBaseControl b m@
--
-- @
-- { MonadBase IO m }
-- @
--
-- Classes used:
--
-- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@
--
-- @
-- { Applicative IO, Applicative m, Monad IO, Monad m }
-- @
--
-- Classes used:
--
-- * @class Monad m@
-- * @class Applicative f => Functor f@
--
-- @
-- { Functor m }
-- @
--
-- Classes used:
--
-- * @class Functor f@
--
-- @
-- { }
-- @
-- ∎
instance (Functor m, MonadIO m, MonadBaseControl IO m)
=> GhcMonad (GhcModT m) where
getSession = (liftIO . readIORef) . gmGhcSession =<< ask
setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask
#if __GLASGOW_HASKELL__ >= 706
instance (Functor m, MonadIO m, MonadBaseControl IO m)
=> HasDynFlags (GhcModT m) where
getDynFlags = getSessionDynFlags
#endif
instance (MonadIO m, MonadBaseControl IO m)
=> ExceptionMonad (GhcModT m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r

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

@ -1,14 +1,15 @@
{-# LANGUAGE BangPatterns, TupleSections #-}
module Language.Haskell.GhcMod.PathsAndFiles where
import Config (cProjectVersion, cTargetPlatformString)
import Config (cProjectVersion)
import Control.Applicative
import Control.Monad
import Data.List
import Data.List.Split (splitOn)
import Data.Char
import Data.Maybe
import Data.Traversable (traverse)
import Distribution.System (buildPlatform)
import Distribution.Text (display)
import Language.Haskell.GhcMod.Types
import System.Directory
import System.FilePath
@ -88,7 +89,6 @@ findCabalSandboxDir dir = do
where
isSandboxConfig = (=="cabal.sandbox.config")
appendDir :: DirPath -> [FileName] -> [FilePath]
appendDir d fs = (d </>) `map` fs
@ -164,6 +164,10 @@ ghcSandboxPkgDbDir =
packageCache :: String
packageCache = "package.cache"
-- | Filename of the show'ed Cabal setup-config cache
prettyConfigCache :: FilePath
prettyConfigCache = setupConfigPath <.> "ghc-mod-0.pretty-cabal-cache"
-- | Filename of the symbol table cache file.
symbolCache :: Cradle -> FilePath
symbolCache crdl = cradleTempDir crdl </> symbolCacheFile

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

@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards, CPP #-}
module Language.Haskell.GhcMod.World where
{-(
, World
@ -12,7 +12,8 @@ import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Control.Applicative (pure,(<$>),(<*>))
import Control.Applicative (pure, (<$>), (<*>))
import Control.Monad
import Data.Maybe
import Data.Traversable (traverse)
import System.Directory (getModificationTime)
@ -45,6 +46,8 @@ data World = World {
worldPackageCaches :: [TimedFile]
, worldCabalFile :: Maybe TimedFile
, worldCabalConfig :: Maybe TimedFile
, worldSymbolCache :: Maybe TimedFile
, worldPrettyCabalConfigCache :: Maybe TimedFile
} deriving (Eq, Show)
timedPackageCache :: Cradle -> IO [TimedFile]
@ -57,15 +60,23 @@ getCurrentWorld :: Cradle -> IO World
getCurrentWorld crdl = do
pkgCaches <- timedPackageCache crdl
mCabalFile <- timeFile `traverse` cradleCabalFile crdl
mSetupConfig <- mightExist (setupConfigFile crdl)
mCabalConfig <- timeFile `traverse` mSetupConfig
mCabalConfig <- timeMaybe (setupConfigFile crdl)
mSymbolCache <- timeMaybe (symbolCache crdl)
mPrettyConfigCache <- timeMaybe prettyConfigCache
return World {
worldPackageCaches = pkgCaches
, worldCabalFile = mCabalFile
, worldCabalConfig = mCabalConfig
, worldSymbolCache = mSymbolCache
, worldPrettyCabalConfigCache = mPrettyConfigCache
}
where
timeMaybe :: FilePath -> IO (Maybe TimedFile)
timeMaybe f = do
join $ (timeFile `traverse`) <$> mightExist f
didWorldChange :: World -> Cradle -> IO Bool
didWorldChange world crdl = do
(world /=) <$> getCurrentWorld crdl
@ -83,7 +94,11 @@ didWorldChange world crdl = do
--
-- * Both files exist
-- @Just cc < Just cf = cc < cf = cc `olderThan` cf@
isSetupConfigOutOfDate :: Cradle -> IO Bool
isSetupConfigOutOfDate crdl = do
world <- getCurrentWorld crdl
return $ worldCabalConfig world < worldCabalFile world
isSetupConfigOutOfDate :: World -> Bool
isSetupConfigOutOfDate World {..} = do
worldCabalConfig < worldCabalFile
isYoungerThanSetupConfig :: FilePath -> World -> IO Bool
isYoungerThanSetupConfig file World {..} = do
tfile <- timeFile file
return $ worldCabalConfig < Just tfile

2
Setup.hs
View File

@ -130,7 +130,7 @@ sanityCheckCabalVersions args cf desc lbi = do
minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10")
when minGhc710 $ do
let cabalHelperCabalVer = compCabalVer CLibName
let cabalHelperCabalVer = compCabalVer (CExeName "cabal-helper")
when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $
failCabalVersionDifferent cabalVer cabalHelperCabalVer

14
ghc-mod.cabal
View File

@ -66,11 +66,13 @@ Library
Default-Extensions: ConstraintKinds, FlexibleContexts
Exposed-Modules: Language.Haskell.GhcMod
Language.Haskell.GhcMod.Internal
Other-Modules: Language.Haskell.GhcMod.Boot
Other-Modules: Paths_ghc_mod
Language.Haskell.GhcMod.Boot
Language.Haskell.GhcMod.Browse
Language.Haskell.GhcMod.CabalConfig.Cabal16
Language.Haskell.GhcMod.CabalConfig.Cabal18
Language.Haskell.GhcMod.CabalConfig.Cabal21
Language.Haskell.GhcMod.CabalConfig.Cabal22
Language.Haskell.GhcMod.CabalConfig.Extract
Language.Haskell.GhcMod.CabalConfig
Language.Haskell.GhcMod.CabalApi
Language.Haskell.GhcMod.CaseSplit
@ -91,8 +93,10 @@ Library
Language.Haskell.GhcMod.Lang
Language.Haskell.GhcMod.Lint
Language.Haskell.GhcMod.Logger
Language.Haskell.GhcMod.Logging
Language.Haskell.GhcMod.Modules
Language.Haskell.GhcMod.Monad
Language.Haskell.GhcMod.Monad.Types
Language.Haskell.GhcMod.PathsAndFiles
Language.Haskell.GhcMod.PkgDoc
Language.Haskell.GhcMod.Read
@ -102,13 +106,9 @@ Library
Language.Haskell.GhcMod.Utils
Language.Haskell.GhcMod.World
if impl(ghc >= 7.10)
Other-Modules: Language.Haskell.GhcMod.CabalConfig.Ghc710
else
Other-Modules: Language.Haskell.GhcMod.CabalConfig.PreGhc710
Build-Depends: base >= 4.0 && < 5
, bytestring
, containers
, deepseq
, directory