diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index 701e5b4..063a1fa 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -13,6 +13,7 @@ import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, mkGHCCompilerId) import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Logging import MonadUtils (liftIO) import Control.Applicative ((<$>)) @@ -36,14 +37,15 @@ import System.FilePath (()) ---------------------------------------------------------------- -- | Getting necessary 'CompilerOptions' from three information sources. -getCompilerOptions :: (IOish m, MonadError GhcModError m) +getCompilerOptions :: (IOish m, GmError m, GmLog m) => [GHCOption] -> Cradle + -> CabalConfig -> PackageDescription -> m CompilerOptions -getCompilerOptions ghcopts cradle pkgDesc = do +getCompilerOptions ghcopts cradle config pkgDesc = do gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos - depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc) + let depPkgs = cabalConfigDependencies config (C.packageId pkgDesc) return $ CompilerOptions gopts idirs depPkgs where wdir = cradleCurrentDir cradle @@ -67,14 +69,14 @@ includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir]) ---------------------------------------------------------------- -- | Parse a cabal file and return a 'PackageDescription'. -parseCabalFile :: (IOish m, MonadError GhcModError m) - => Cradle +parseCabalFile :: (IOish m, GmError m, GmLog m) + => CabalConfig -> FilePath -> m PackageDescription -parseCabalFile cradle file = do +parseCabalFile config file = do cid <- mkGHCCompilerId <$> liftIO getGHCVersion epgd <- liftIO $ readPackageDescription silent file - flags <- cabalConfigFlags cradle + flags <- cabalConfigFlags config case toPkgDesc cid flags epgd of Left deps -> fail $ show deps ++ " are not installed" Right (pd,_) -> if nullPkg pd diff --git a/Language/Haskell/GhcMod/CabalConfig.hs b/Language/Haskell/GhcMod/CabalConfig.hs index 79f48d7..2d9d9da 100644 --- a/Language/Haskell/GhcMod/CabalConfig.hs +++ b/Language/Haskell/GhcMod/CabalConfig.hs @@ -4,39 +4,32 @@ -- 'LocalBuildInfo' (@dist/setup-config@) for different version combinations of -- Cabal and GHC. module Language.Haskell.GhcMod.CabalConfig ( - cabalConfigDependencies + CabalConfig + , cabalGetConfig + , cabalConfigDependencies , cabalConfigFlags ) where -import Control.Applicative import Distribution.Package (PackageIdentifier) import Distribution.PackageDescription (FlagAssignment) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Error -#if __GLASGOW_HASKELL__ >= 710 -import Language.Haskell.GhcMod.CabalConfig.Ghc710 -#else -import Language.Haskell.GhcMod.CabalConfig.PreGhc710 -#endif +import Language.Haskell.GhcMod.CabalConfig.Extract +cabalGetConfig :: (IOish m, GmError m) => Cradle -> m CabalConfig +cabalGetConfig = getConfig -- | Get list of 'Package's needed by all components of the current package -cabalConfigDependencies :: (IOish m, MonadError GhcModError m) - => Cradle - -> PackageIdentifier - -> m [Package] -cabalConfigDependencies cradle thisPkg = - configDependencies thisPkg <$> getConfig cradle +cabalConfigDependencies :: CabalConfig -> PackageIdentifier -> [Package] +cabalConfigDependencies config thisPkg = + configDependencies thisPkg config -- | Get the flag assignment from the local build info of the given cradle -cabalConfigFlags :: (IOish m, MonadError GhcModError m) - => Cradle - -> m FlagAssignment -cabalConfigFlags cradle = do - config <- getConfig cradle +cabalConfigFlags :: (IOish m, GmError m) => CabalConfig -> m FlagAssignment +cabalConfigFlags config = do case configFlags config of Right x -> return x Left msg -> throwError (GMECabalFlags (GMEString msg)) diff --git a/Language/Haskell/GhcMod/CabalConfig/Cabal22.hs b/Language/Haskell/GhcMod/CabalConfig/Cabal22.hs new file mode 100644 index 0000000..da6ef88 --- /dev/null +++ b/Language/Haskell/GhcMod/CabalConfig/Cabal22.hs @@ -0,0 +1,107 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +-- Copyright : Isaac Jones 2003-2004 +-- Copyright : (c) The University of Glasgow 2004 +-- Copyright : Duncan Coutts 2008 +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +-- | ComponentLocalBuildInfo for Cabal >= 1.22 +module Language.Haskell.GhcMod.CabalConfig.Cabal22 ( + ComponentLocalBuildInfo + , PackageIdentifier(..) + , PackageName(..) + , componentPackageDeps + , componentLibraries + ) where + +import Distribution.Package (InstalledPackageId) +import Data.Version (Version) +import Data.Map (Map) + +data LibraryName = LibraryName String + deriving (Read, Show) + +newtype PackageName = PackageName { unPackageName :: String } + deriving (Read, Show, Ord, Eq) + +data PackageIdentifier + = PackageIdentifier { + pkgName :: PackageName, + pkgVersion :: Version + } + deriving (Read, Show) + +type PackageId = PackageIdentifier + +newtype ModuleName = ModuleName [String] + deriving (Read, Show) + +data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)] + deriving (Read, Show) + +data OriginalModule + = OriginalModule { + originalPackageId :: InstalledPackageId, + originalModuleName :: ModuleName + } + deriving (Read, Show) + +data ExposedModule + = ExposedModule { + exposedName :: ModuleName, + exposedReexport :: Maybe OriginalModule, + exposedSignature :: Maybe OriginalModule -- This field is unused for now. + } + deriving (Read, Show) + +data ComponentLocalBuildInfo + = LibComponentLocalBuildInfo { + -- | Resolved internal and external package dependencies for this component. + -- The 'BuildInfo' specifies a set of build dependencies that must be + -- satisfied in terms of version ranges. This field fixes those dependencies + -- to the specific versions available on this machine for this compiler. + componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentExposedModules :: [ExposedModule], + componentPackageRenaming :: Map PackageName ModuleRenaming, + componentLibraries :: [LibraryName] + } + | ExeComponentLocalBuildInfo { + componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentPackageRenaming :: Map PackageName ModuleRenaming + } + | TestComponentLocalBuildInfo { + componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentPackageRenaming :: Map PackageName ModuleRenaming + } + | BenchComponentLocalBuildInfo { + componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentPackageRenaming :: Map PackageName ModuleRenaming + } + deriving (Read, Show) diff --git a/Language/Haskell/GhcMod/CabalConfig/Extract.hs b/Language/Haskell/GhcMod/CabalConfig/Extract.hs new file mode 100644 index 0000000..ea0c3bd --- /dev/null +++ b/Language/Haskell/GhcMod/CabalConfig/Extract.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE RecordWildCards, CPP, OverloadedStrings #-} + +-- | This module facilitates extracting information from Cabal's on-disk +-- 'LocalBuildInfo' (@dist/setup-config@). +module Language.Haskell.GhcMod.CabalConfig.Extract ( + CabalConfig + , configDependencies + , configFlags + , getConfig + ) where + +import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.Read +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Utils +import Language.Haskell.GhcMod.World + +import qualified Language.Haskell.GhcMod.CabalConfig.Cabal16 as C16 +import qualified Language.Haskell.GhcMod.CabalConfig.Cabal18 as C18 +import qualified Language.Haskell.GhcMod.CabalConfig.Cabal22 as C22 + +#ifndef MIN_VERSION_mtl +#define MIN_VERSION_mtl(x,y,z) 1 +#endif + +import Control.Applicative ((<$>)) +import Control.Monad (void, mplus, when) +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except () +#else +import Control.Monad.Error () +#endif +import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) +import Data.Version +import Distribution.Package (InstalledPackageId(..) + , PackageIdentifier(..) + , PackageName(..)) +import Distribution.PackageDescription (FlagAssignment) +import Distribution.Simple.LocalBuildInfo (ComponentName) +import MonadUtils (liftIO) +import Text.ParserCombinators.ReadP + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +---------------------------------------------------------------- + +-- | 'Show'ed cabal 'LocalBuildInfo' string +newtype CabalConfig = CabalConfig { unCabalConfig :: String } + +-- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't +-- exist run @cabal configure@ i.e. configure with default options like @cabal +-- build@ would do. +getConfig :: (IOish m, GmError m) => Cradle -> m CabalConfig +getConfig crdl = do + liftIO (getCurrentWorld crdl) >>= \world -> + when (isSetupConfigOutOfDate world) configure + + cfg <- liftIO (BS.readFile file) `tryFix` \_ -> + configure `modifyError'` GMECabalConfigure + + liftIO (getCurrentWorld crdl) >>= \world -> + decodeConfig crdl world file cfg + where + file = setupConfigFile crdl + prjDir = cradleRootDir crdl + + configure :: (IOish m, GmError m) => m () + configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] + +decodeConfig :: (IOish m, GmError m) + => Cradle -> World -> FilePath -> ByteString -> m CabalConfig +decodeConfig _crdl _world file bs = CabalConfig <$> gen + +-- if cacheOutdated world +-- then +-- gmLog $ "Regenerating pretty setup-config cache: " ++ prettyConfigCache +-- liftIO $ writeFile prettyConfigCache cfg +-- else CabalConfig <$> liftIO (readFile prettyConfigCache) + + where + -- cacheOutdated World {..} = + -- case (worldCabalConfig, worldPrettyCabalConfigCache) of + -- (Nothing, _) -> error "decodeConfig: setup-config does not exist." + -- (Just _, Nothing) -> True + -- (Just s, Just p) -> s > p + + gen = case BS8.lines bs of + header:_ -> do + ((_,cabalVer), _) <- parseHeader header + if cabalVer >= (Version [1,22] []) + then prettyPrintBinaryConfig file + else return $ bsToStr bs + [] -> throwError $ GMECabalStateFile GMConfigStateFileNoHeader + +prettyPrintBinaryConfig :: (IOish m, GmError m) + => String -> m String +prettyPrintBinaryConfig file = do + exe <- liftIO $ findLibexecExe "ghc-mod-cabal" + slbi <- readProcess' exe ["print-setup-config", file] + return slbi + +parseHeader :: GmError m + => ByteString -> m ((ByteString, Version), (ByteString, Version)) +parseHeader header = case BS8.words header of + ["Saved", "package", "config", "for", _pkgId , "written", "by", cabalId, "using", compId] -> modifyError (\_ -> GMECabalStateFile GMConfigStateFileBadHeader) $ do + cabalId' <- parsePkgId cabalId + compId' <- parsePkgId compId + return (cabalId', compId') + + _ -> throwError $ GMECabalStateFile GMConfigStateFileNoHeader + +parsePkgId :: (Error e, MonadError e m) => ByteString -> m (ByteString, Version) +parsePkgId bs = + case BS8.split '-' bs of + [pkg, vers] -> return (pkg, parseVer vers) + _ -> throwError noMsg + where + parseVer vers = + let (ver,""):[] = + filter ((=="") . snd) $ readP_to_S parseVersion (bsToStr vers) + in ver + +bsToStr :: ByteString -> String +bsToStr = T.unpack . T.decodeUtf8 + +-- strToBs :: String -> ByteString +-- strToBs = T.encodeUtf8 . T.pack + +-- | Extract list of depencenies for all components from 'CabalConfig' +configDependencies :: PackageIdentifier -> CabalConfig -> [Package] +configDependencies thisPkg config = map fromInstalledPackageId deps + where + deps :: [InstalledPackageId] + deps = case deps16 `mplus` deps18 `mplus` deps22 of + Right ps -> ps + Left msg -> error msg + + -- True if this dependency is an internal one (depends on the library + -- defined in the same package). + internal pkgid = pkgid == thisPkg + + -- Cabal >= 1.22 + deps22 :: Either String [InstalledPackageId] + deps22 = + map fst + <$> filterInternal22 + <$> (readEither =<< extractField (unCabalConfig config) "componentsConfigs") + + filterInternal22 + :: [(ComponentName, C22.ComponentLocalBuildInfo, [ComponentName])] + -> [(InstalledPackageId, C22.PackageIdentifier)] + + filterInternal22 ccfg = [ (ipkgid, pkgid) + | (_,clbi,_) <- ccfg + , (ipkgid, pkgid) <- C22.componentPackageDeps clbi + , not (internal . packageIdentifierFrom22 $ pkgid) ] + + packageIdentifierFrom22 :: C22.PackageIdentifier -> PackageIdentifier + packageIdentifierFrom22 (C22.PackageIdentifier (C22.PackageName myName) myVersion) = + PackageIdentifier (PackageName myName) myVersion + + -- Cabal >= 1.18 && < 1.20 + deps18 :: Either String [InstalledPackageId] + deps18 = + map fst + <$> filterInternal + <$> (readEither =<< extractField (unCabalConfig config) "componentsConfigs") + + filterInternal + :: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])] + -> [(InstalledPackageId, PackageIdentifier)] + + filterInternal ccfg = [ (ipkgid, pkgid) + | (_,clbi,_) <- ccfg + , (ipkgid, pkgid) <- C18.componentPackageDeps clbi + , not (internal pkgid) ] + + -- Cabal 1.16 and below + deps16 :: Either String [InstalledPackageId] + deps16 = map fst <$> filter (not . internal . snd) . nub <$> do + cbi <- concat <$> sequence [ extract "executableConfigs" + , extract "testSuiteConfigs" + , extract "benchmarkConfigs" ] + :: Either String [(String, C16.ComponentLocalBuildInfo)] + + return $ maybe [] C16.componentPackageDeps libraryConfig + ++ concatMap (C16.componentPackageDeps . snd) cbi + where + libraryConfig :: Maybe C16.ComponentLocalBuildInfo + libraryConfig = do + field <- find ("libraryConfig" `isPrefixOf`) (tails $ unCabalConfig config) + clbi <- stripPrefix " = " field + if "Nothing" `isPrefixOf` clbi + then Nothing + else case readMaybe =<< stripPrefix "Just " clbi of + Just x -> x + Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi) + + extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)] + extract field = readConfigs field <$> extractField (unCabalConfig config) field + + readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)] + readConfigs f s = case readEither s of + Right x -> x + Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")" + +-- | Extract the cabal flags from the 'CabalConfig' +configFlags :: CabalConfig -> Either String FlagAssignment +configFlags (CabalConfig config) = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags" + +-- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable +-- error message with lots of context on failure. +extractField :: String -> String -> Either String String +extractField content field = + case extractParens <$> find (field `isPrefixOf`) (tails content) of + Just f -> Right f + Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` content) diff --git a/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs b/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs index 2f0b41c..76e5308 100644 --- a/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs +++ b/Language/Haskell/GhcMod/CabalConfig/Ghc710.hs @@ -17,6 +17,7 @@ import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World @@ -24,19 +25,18 @@ import Language.Haskell.GhcMod.World -- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't -- exist run @cabal configure@ i.e. configure with default options like @cabal -- build@ would do. -getConfig :: (IOish m, MonadError GhcModError m) +getConfig :: (IOish m, GmError m) => Cradle -> m LocalBuildInfo -getConfig cradle = do - outOfDate <- liftIO $ isSetupConfigOutOfDate cradle - when outOfDate configure +getConfig cradle = liftIO (getCurrentWorld cradle) >>= \world -> do + when (isSetupConfigOutOfDate world) configure liftIO (getConfigStateFile file) `tryFix` \_ -> configure `modifyError'` GMECabalConfigure where file = setupConfigFile cradle prjDir = cradleRootDir cradle - configure :: (IOish m, MonadError GhcModError m) => m () + configure :: (IOish m, GmError m) => m () configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] configDependencies :: a -> LocalBuildInfo -> [Package] diff --git a/Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs b/Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs deleted file mode 100644 index f243487..0000000 --- a/Language/Haskell/GhcMod/CabalConfig/PreGhc710.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE RecordWildCards, CPP #-} - --- | This module facilitates extracting information from Cabal's on-disk --- 'LocalBuildInfo' (@dist/setup-config@). -module Language.Haskell.GhcMod.CabalConfig.PreGhc710 ( - configDependencies - , configFlags - , getConfig - ) where - -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.Read -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.World - -import qualified Language.Haskell.GhcMod.CabalConfig.Cabal16 as C16 -import qualified Language.Haskell.GhcMod.CabalConfig.Cabal18 as C18 -import qualified Language.Haskell.GhcMod.CabalConfig.Cabal21 as C21 - -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(x,y,z) 1 -#endif - -import Control.Applicative ((<$>)) -import Control.Monad (void, mplus, when) -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except () -#else -import Control.Monad.Error () -#endif -import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) -import Distribution.Package (InstalledPackageId(..) - , PackageIdentifier(..) - , PackageName(..)) -import Distribution.PackageDescription (FlagAssignment) -import Distribution.Simple.LocalBuildInfo (ComponentName) -import MonadUtils (liftIO) - ----------------------------------------------------------------- - --- | 'Show'ed cabal 'LocalBuildInfo' string -type CabalConfig = String - --- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't --- exist run @cabal configure@ i.e. configure with default options like @cabal --- build@ would do. -getConfig :: (IOish m, MonadError GhcModError m) - => Cradle - -> m CabalConfig -getConfig cradle = do - outOfDate <- liftIO $ isSetupConfigOutOfDate cradle - when outOfDate configure - liftIO (readFile file) `tryFix` \_ -> - configure `modifyError'` GMECabalConfigure - where - file = setupConfigFile cradle - prjDir = cradleRootDir cradle - - configure :: (IOish m, MonadError GhcModError m) => m () - configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] - - --- | Extract list of depencenies for all components from 'CabalConfig' -configDependencies :: PackageIdentifier -> CabalConfig -> [Package] -configDependencies thisPkg config = map fromInstalledPackageId deps - where - deps :: [InstalledPackageId] - deps = case deps21 `mplus` deps18 `mplus` deps16 of - Right ps -> ps - Left msg -> error msg - - -- True if this dependency is an internal one (depends on the library - -- defined in the same package). - internal pkgid = pkgid == thisPkg - - -- Cabal >= 1.21 - deps21 :: Either String [InstalledPackageId] - deps21 = - map fst - <$> filterInternal21 - <$> (readEither =<< extractField config "componentsConfigs") - - filterInternal21 - :: [(ComponentName, C21.ComponentLocalBuildInfo, [ComponentName])] - -> [(InstalledPackageId, C21.PackageIdentifier)] - - filterInternal21 ccfg = [ (ipkgid, pkgid) - | (_,clbi,_) <- ccfg - , (ipkgid, pkgid) <- C21.componentPackageDeps clbi - , not (internal . packageIdentifierFrom21 $ pkgid) ] - - packageIdentifierFrom21 :: C21.PackageIdentifier -> PackageIdentifier - packageIdentifierFrom21 (C21.PackageIdentifier (C21.PackageName myName) myVersion) = - PackageIdentifier (PackageName myName) myVersion - - -- Cabal >= 1.18 && < 1.21 - deps18 :: Either String [InstalledPackageId] - deps18 = - map fst - <$> filterInternal - <$> (readEither =<< extractField config "componentsConfigs") - - filterInternal - :: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])] - -> [(InstalledPackageId, PackageIdentifier)] - - filterInternal ccfg = [ (ipkgid, pkgid) - | (_,clbi,_) <- ccfg - , (ipkgid, pkgid) <- C18.componentPackageDeps clbi - , not (internal pkgid) ] - - -- Cabal 1.16 and below - deps16 :: Either String [InstalledPackageId] - deps16 = map fst <$> filter (not . internal . snd) . nub <$> do - cbi <- concat <$> sequence [ extract "executableConfigs" - , extract "testSuiteConfigs" - , extract "benchmarkConfigs" ] - :: Either String [(String, C16.ComponentLocalBuildInfo)] - - return $ maybe [] C16.componentPackageDeps libraryConfig - ++ concatMap (C16.componentPackageDeps . snd) cbi - where - libraryConfig :: Maybe C16.ComponentLocalBuildInfo - libraryConfig = do - field <- find ("libraryConfig" `isPrefixOf`) (tails config) - clbi <- stripPrefix " = " field - if "Nothing" `isPrefixOf` clbi - then Nothing - else case readMaybe =<< stripPrefix "Just " clbi of - Just x -> x - Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi) - - extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)] - extract field = readConfigs field <$> extractField config field - - readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)] - readConfigs f s = case readEither s of - Right x -> x - Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")" - --- | Extract the cabal flags from the 'CabalConfig' -configFlags :: CabalConfig -> Either String FlagAssignment -configFlags config = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags" - --- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable --- error message with lots of context on failure. -extractField :: CabalConfig -> String -> Either String String -extractField config field = - case extractParens <$> find (field `isPrefixOf`) (tails config) of - Just f -> Right f - Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config) diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index f1382ce..f092d3e 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -6,6 +6,7 @@ import Data.Maybe (isJust, fromJust) import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.CabalConfig import Language.Haskell.GhcMod.Internal ---------------------------------------------------------------- @@ -30,9 +31,10 @@ debugInfo = cradle >>= \c -> convert' =<< do where simpleCompilerOption = options >>= \op -> return $ CompilerOptions (ghcUserOptions op) [] [] - fromCabalFile c = options >>= \opts -> do - pkgDesc <- parseCabalFile c $ fromJust $ cradleCabalFile c - getCompilerOptions (ghcUserOptions opts) c pkgDesc + fromCabalFile crdl = options >>= \opts -> do + config <- cabalGetConfig crdl + pkgDesc <- parseCabalFile config $ fromJust $ cradleCabalFile crdl + getCompilerOptions (ghcUserOptions opts) crdl config pkgDesc ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 9fa2b80..a05b1e1 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -1,6 +1,8 @@ {-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-} module Language.Haskell.GhcMod.Error ( GhcModError(..) + , GMConfigStateFileError(..) + , GmError , gmeDoc , modifyError , modifyError' @@ -15,26 +17,81 @@ import Data.Typeable import Exception import Text.PrettyPrint +type GmError m = MonadError GhcModError m + data GhcModError = GMENoMsg -- ^ Unknown error + | GMEString String -- ^ Some Error with a message. These are produced mostly by -- 'fail' calls on GhcModT. + | GMEIOException IOException -- ^ IOExceptions captured by GhcModT's MonadIO instance + | GMECabalConfigure GhcModError -- ^ Configuring a cabal project failed. + | GMECabalFlags GhcModError -- ^ Retrieval of the cabal configuration flags failed. + | GMEProcess [String] GhcModError -- ^ Launching an operating system process failed. The first -- field is the command. + | GMENoCabalFile -- ^ No cabal file found. + | GMETooManyCabalFiles [FilePath] -- ^ Too many cabal files found. + + | GMECabalStateFile GMConfigStateFileError + -- ^ Reading Cabal's state configuration file falied somehow. deriving (Eq,Show,Typeable) +data GMConfigStateFileError + = GMConfigStateFileNoHeader + | GMConfigStateFileBadHeader + | GMConfigStateFileNoParse + | GMConfigStateFileMissing +-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) + deriving (Eq, Show, Read, Typeable) + +gmCsfeDoc :: GMConfigStateFileError -> Doc +gmCsfeDoc GMConfigStateFileNoHeader = text $ + "Saved package config file header is missing. " + ++ "Try re-running the 'configure' command." + +gmCsfeDoc GMConfigStateFileBadHeader = text $ + "Saved package config file header is corrupt. " + ++ "Try re-running the 'configure' command." + +gmCsfeDoc GMConfigStateFileNoParse = text $ + "Saved package config file body is corrupt. " + ++ "Try re-running the 'configure' command." + +gmCsfeDoc GMConfigStateFileMissing = text $ + "Run the 'configure' command first." + +-- gmCsfeDoc (ConfigStateFileBadVersion oldCabal oldCompiler _) = text $ +-- "You need to re-run the 'configure' command. " +-- ++ "The version of Cabal being used has changed (was " +-- ++ display oldCabal ++ ", now " +-- ++ display currentCabalId ++ ")." +-- ++ badCompiler +-- where +-- badCompiler +-- | oldCompiler == currentCompilerId = "" +-- | otherwise = +-- " Additionally the compiler is different (was " +-- ++ display oldCompiler ++ ", now " +-- ++ display currentCompilerId +-- ++ ") which is probably the cause of the problem." + + + + + instance Exception GhcModError instance Error GhcModError where @@ -61,6 +118,9 @@ gmeDoc e = case e of GMETooManyCabalFiles cfs -> text $ "Multiple cabal files found. Possible cabal files: \"" ++ intercalate "\", \"" cfs ++"\"." + GMECabalStateFile csfe -> + gmCsfeDoc csfe + modifyError :: MonadError e m => (e -> e) -> m a -> m a modifyError f action = action `catchError` \e -> throwError $ f e diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs new file mode 100644 index 0000000..62a8412 --- /dev/null +++ b/Language/Haskell/GhcMod/Logging.hs @@ -0,0 +1,21 @@ +module Language.Haskell.GhcMod.Logging where + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types + +import Control.Monad.Journal.Class +import Control.Monad.Trans.Class +import System.IO + +import MonadUtils + +--gmSink :: IOish m => (GhcModLog -> IO ()) -> GhcModT m () +--gmSink = GhcModT . (lift . lift . sink) + +type GmLog m = MonadJournal GhcModLog m + +gmJournal :: IOish m => GhcModLog -> GhcModT m () +gmJournal = GhcModT . lift . lift . journal + +gmLog :: (MonadIO m, MonadJournal GhcModLog m) => String -> m () +gmLog str = liftIO (hPutStrLn stderr str) >> (journal $ GhcModLog [str]) diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index cbc2880..6be1b23 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -1,9 +1,4 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} -{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - +{-# LANGUAGE CPP, RecordWildCards #-} module Language.Haskell.GhcMod.Monad ( -- * Monad Types GhcModT @@ -20,41 +15,32 @@ module Language.Haskell.GhcMod.Monad ( , runGhcModT , runGhcModT' , hoistGhcModT - -- ** Accessing 'GhcModEnv' and 'GhcModState' + -- ** Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog' , gmsGet , gmsPut + , gmLog , options , cradle , getCompilerMode , setCompilerMode , withOptions , withTempSession - , overrideGhcUserOptions -- ** Re-exporting convenient stuff , liftIO , module Control.Monad.Reader.Class - , module Control.Monad.Journal.Class ) where -#if __GLASGOW_HASKELL__ < 708 --- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different --- classes before ghc 7.8 -#define DIFFERENT_MONADIO 1 - --- RWST doen't have a MonadIO instance before ghc 7.8 -#define MONADIO_INSTANCES 1 -#endif - - import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.CabalApi +import Language.Haskell.GhcMod.CabalConfig import qualified Language.Haskell.GhcMod.Gap as Gap -import DynFlags import GHC import qualified GHC as G import GHC.Paths (libdir) @@ -69,154 +55,36 @@ import HscTypes -- So, RWST automatically becomes an instance of MonadIO. import MonadUtils -#if DIFFERENT_MONADIO -import Control.Monad.Trans.Class (lift) -import qualified Control.Monad.IO.Class -import Data.Monoid (Monoid) -#endif - -import Control.Applicative (Alternative) import Control.Arrow (first) -import Control.Monad (MonadPlus, void) +import Control.Monad (void) #if !MIN_VERSION_monad_control(1,0,0) import Control.Monad (liftM) #endif -import Control.Monad.Base (MonadBase, liftBase) +import Control.Monad.Base (liftBase) --- Monad transformer stuff -import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, - control, liftBaseOp, liftBaseOp_) - -import Control.Monad.Trans.Class import Control.Monad.Reader.Class -import Control.Monad.Writer.Class (MonadWriter) import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Error (ErrorT, runErrorT) -import Control.Monad.Reader (ReaderT, runReaderT) -import Control.Monad.State.Strict (StateT, runStateT) -import Control.Monad.Trans.Journal (JournalT, runJournalT) -#ifdef MONADIO_INSTANCES -import Control.Monad.Trans.Maybe (MaybeT) -import Control.Monad.Error (Error(..)) -#endif -import Control.Monad.Journal.Class +import Control.Monad.Error (runErrorT) +import Control.Monad.Reader (runReaderT) +import Control.Monad.State.Strict (runStateT) +import Control.Monad.Trans.Journal (runJournalT) import Data.Maybe (isJust) -import Data.IORef (IORef, readIORef, writeIORef, newIORef) +import Data.IORef import System.Directory (getCurrentDirectory) ---------------------------------------------------------------- -data GhcModEnv = GhcModEnv { - gmGhcSession :: !(IORef HscEnv) - , gmOptions :: Options - , gmCradle :: Cradle - } - -type GhcModLog = () - -data GhcModState = GhcModState { - gmCompilerMode :: CompilerMode - } deriving (Eq,Show,Read) - -data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read) - -defaultState :: GhcModState -defaultState = GhcModState Simple - ----------------------------------------------------------------- - --- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT' --- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that --- means you can run (almost) all functions from the GHC API on top of 'GhcModT' --- transparently. --- --- The inner monad @m@ should have instances for 'MonadIO' and --- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@ --- monads already have 'MonadBaseControl' 'IO' instances, see the --- @monad-control@ package. -newtype GhcModT m a = GhcModT { - unGhcModT :: StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) a - } deriving ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus -#if DIFFERENT_MONADIO - , Control.Monad.IO.Class.MonadIO -#endif - , MonadReader GhcModEnv -- TODO: make MonadReader instance - -- pass-through like MonadState - , MonadWriter w - , MonadError GhcModError - ) - -instance MonadIO m => MonadIO (GhcModT m) where - liftIO action = do - res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action - case res of - Right a -> return a - - Left e | isIOError e -> - throwError $ GMEIOException (fromEx e :: IOError) - Left e | isGhcModError e -> - throwError $ (fromEx e :: GhcModError) - Left e -> throw e - - where - fromEx :: Exception e => SomeException -> e - fromEx se = let Just e = fromException se in e - isIOError se = - case fromException se of - Just (_ :: IOError) -> True - Nothing -> False - - isGhcModError se = - case fromException se of - Just (_ :: GhcModError) -> True - Nothing -> False - - -instance MonadTrans (GhcModT) where - lift = GhcModT . lift . lift . lift . lift - -instance MonadState s m => MonadState s (GhcModT m) where - get = GhcModT $ lift $ lift $ lift get - put = GhcModT . lift . lift . lift . put - state = GhcModT . lift . lift . lift . state - - -#if MONADIO_INSTANCES -instance MonadIO m => MonadIO (StateT s m) where - liftIO = lift . liftIO - -instance MonadIO m => MonadIO (ReaderT r m) where - liftIO = lift . liftIO - -instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where - liftIO = lift . liftIO - -instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where - liftIO = lift . liftIO - -instance MonadIO m => MonadIO (MaybeT m) where - liftIO = lift . liftIO -#endif - ----------------------------------------------------------------- - -- | Initialize the 'DynFlags' relating to the compilation of a single -- file or GHC session according to the 'Cradle' and 'Options' -- provided. -initializeFlagsWithCradle :: (IOish m, GhcMonad m, MonadError GhcModError m) +initializeFlagsWithCradle :: (IOish m, GhcMonad m, GmError m, GmLog m) => Options -> Cradle + -> CabalConfig -> m () -initializeFlagsWithCradle opt c +initializeFlagsWithCradle opt c config | cabal = withCabal | otherwise = withSandbox where @@ -228,8 +96,8 @@ initializeFlagsWithCradle opt c withCabal = do let Just cabalFile = mCabalFile - pkgDesc <- parseCabalFile c cabalFile - compOpts <- getCompilerOptions ghcopts c pkgDesc + pkgDesc <- parseCabalFile config cabalFile + compOpts <- getCompilerOptions ghcopts c config pkgDesc initSession CabalPkg opt compOpts withSandbox = initSession SingleFile opt compOpts @@ -283,8 +151,9 @@ runGhcModT opt action = gbracket newEnv delEnv $ \env -> do r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do dflags <- getSessionDynFlags defaultCleanupHandler dflags $ do - initializeFlagsWithCradle opt (gmCradle env) - action) + config <- cabalGetConfig =<< cradle + initializeFlagsWithCradle opt (gmCradle env) config + action ) return r where @@ -298,7 +167,7 @@ hoistGhcModT :: IOish m => (Either GhcModError a, GhcModLog) -> GhcModT m a hoistGhcModT (r,l) = do - GhcModT (lift $ lift $ journal l) >> case r of + gmJournal l >> case r of Left e -> throwError e Right a -> return a @@ -328,18 +197,6 @@ withTempSession action = do liftIO $ writeIORef session savedHscEnv return a --- | This is a very ugly workaround don't use it. -overrideGhcUserOptions :: IOish m => ([GHCOption] -> GhcModT m b) -> GhcModT m b -overrideGhcUserOptions action = withTempSession $ do - env <- ask - opt <- options - let ghcOpts = ghcUserOptions opt - opt' = opt { ghcUserOptions = [] } - - initializeFlagsWithCradle opt' (gmCradle env) - - action ghcOpts - ---------------------------------------------------------------- gmeAsk :: IOish m => GhcModT m GhcModEnv @@ -373,113 +230,3 @@ withOptions changeOpt action = local changeEnv action opt = gmOptions e ---------------------------------------------------------------- - -instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where - liftBase = GhcModT . liftBase - -#if MIN_VERSION_monad_control(1,0,0) - -instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where - type StM (GhcModT m) a = - StM (StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) ) a - liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> - f $ runInBase . unGhcModT - - restoreM = GhcModT . restoreM - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} - -#else - -instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where - newtype StM (GhcModT m) a = StGhcMod { - unStGhcMod :: StM (StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) ) a } - liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> - f $ liftM StGhcMod . runInBase . unGhcModT - - restoreM = GhcModT . restoreM . unStGhcMod - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} - -#endif - --- GHC cannot prove the following instances to be decidable automatically using --- the FlexibleContexts extension as they violate the second Paterson Condition, --- namely that: The assertion has fewer constructors and variables (taken --- together and counting repetitions) than the head. Specifically the --- @MonadBaseControl IO m@ constraint is causing this violation. --- --- Proof of termination: --- --- Assuming all constraints containing the variable `m' exist and are decidable --- we show termination by manually replacing the current set of constraints with --- their own set of constraints and show that this, after a finite number of --- steps, results in the empty set, i.e. not having to check any more --- constraints. --- --- We start by setting the constraints to be those immediate constraints of the --- instance declaration which cannot be proven decidable automatically for the --- type under consideration. --- --- @ --- { MonadBaseControl IO m } --- @ --- --- Classes used: --- --- * @class MonadBase b m => MonadBaseControl b m@ --- --- @ --- { MonadBase IO m } --- @ --- --- Classes used: --- --- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@ --- --- @ --- { Applicative IO, Applicative m, Monad IO, Monad m } --- @ --- --- Classes used: --- --- * @class Monad m@ --- * @class Applicative f => Functor f@ --- --- @ --- { Functor m } --- @ --- --- Classes used: --- --- * @class Functor f@ --- --- @ --- { } --- @ --- ∎ - -instance (Functor m, MonadIO m, MonadBaseControl IO m) - => GhcMonad (GhcModT m) where - getSession = (liftIO . readIORef) . gmGhcSession =<< ask - setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask - -#if __GLASGOW_HASKELL__ >= 706 -instance (Functor m, MonadIO m, MonadBaseControl IO m) - => HasDynFlags (GhcModT m) where - getDynFlags = getSessionDynFlags -#endif - -instance (MonadIO m, MonadBaseControl IO m) - => ExceptionMonad (GhcModT m) where - gcatch act handler = control $ \run -> - run act `gcatch` (run . handler) - - gmask = liftBaseOp gmask . liftRestore - where liftRestore f r = f $ liftBaseOp_ r diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs new file mode 100644 index 0000000..0cd2494 --- /dev/null +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.Haskell.GhcMod.Monad.Types where + + +#if __GLASGOW_HASKELL__ < 708 +-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different +-- classes before ghc 7.8 +#define DIFFERENT_MONADIO 1 + +-- RWST doen't have a MonadIO instance before ghc 7.8 +#define MONADIO_INSTANCES 1 +#endif + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Error + +import GHC +import DynFlags +import GhcMonad hiding (withTempSession) +#if __GLASGOW_HASKELL__ <= 702 +import HscTypes +#endif + +-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. +-- RWST does not automatically become an instance of MonadIO. +-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. +-- So, RWST automatically becomes an instance of MonadIO. +import MonadUtils + +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus) +import Control.Monad.Error (ErrorT) +import Control.Monad.Reader (ReaderT) +import Control.Monad.State.Strict (StateT) +import Control.Monad.Trans.Journal (JournalT) + +import Control.Monad.Base (MonadBase, liftBase) +import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, + control, liftBaseOp, liftBaseOp_) + +import Control.Monad.Trans.Class +import Control.Monad.Reader.Class +import Control.Monad.Writer.Class (MonadWriter) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Journal.Class (MonadJournal(..)) + +#ifdef MONADIO_INSTANCES +import Control.Monad.Trans.Maybe (MaybeT) +import Control.Monad.Error (Error(..)) +#endif + +#if DIFFERENT_MONADIO +import Control.Monad.Trans.Class (lift) +import qualified Control.Monad.IO.Class +import Data.Monoid (Monoid) +#endif + +#if !MIN_VERSION_monad_control(1,0,0) +import Control.Monad (liftM) +#endif + +import Data.Monoid +import Data.IORef + +data GhcModEnv = GhcModEnv { + gmGhcSession :: !(IORef HscEnv) + , gmOptions :: Options + , gmCradle :: Cradle + } + +data GhcModLog = GhcModLog { + gmLogMessages :: [String] + } deriving (Eq, Show, Read) + +instance Monoid GhcModLog where + mempty = GhcModLog mempty + GhcModLog a `mappend` GhcModLog b = GhcModLog (a `mappend` b) + +data GhcModState = GhcModState { + gmCompilerMode :: CompilerMode + } deriving (Eq,Show,Read) + +data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read) + +defaultState :: GhcModState +defaultState = GhcModState Simple + +---------------------------------------------------------------- + +-- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT' +-- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that +-- means you can run (almost) all functions from the GHC API on top of 'GhcModT' +-- transparently. +-- +-- The inner monad @m@ should have instances for 'MonadIO' and +-- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@ +-- monads already have 'MonadBaseControl' 'IO' instances, see the +-- @monad-control@ package. +newtype GhcModT m a = GhcModT { + unGhcModT :: StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) a + } deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus +#if DIFFERENT_MONADIO + , Control.Monad.IO.Class.MonadIO +#endif + , MonadReader GhcModEnv -- TODO: make MonadReader instance + -- pass-through like MonadState + , MonadWriter w + , MonadError GhcModError + ) + +instance MonadIO m => MonadIO (GhcModT m) where + liftIO action = do + res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action + case res of + Right a -> return a + + Left e | isIOError e -> + throwError $ GMEIOException (fromEx e :: IOError) + Left e | isGhcModError e -> + throwError $ (fromEx e :: GhcModError) + Left e -> throw e + + where + fromEx :: Exception e => SomeException -> e + fromEx se = let Just e = fromException se in e + + isIOError se = + case fromException se of + Just (_ :: IOError) -> True + Nothing -> False + + isGhcModError se = + case fromException se of + Just (_ :: GhcModError) -> True + Nothing -> False + +instance (Monad m) => MonadJournal GhcModLog (GhcModT m) where + journal !w = GhcModT $ lift $ lift $ (journal w) + history = GhcModT $ lift $ lift $ history + clear = GhcModT $ lift $ lift $ clear + +instance MonadTrans GhcModT where + lift = GhcModT . lift . lift . lift . lift + +instance MonadState s m => MonadState s (GhcModT m) where + get = GhcModT $ lift $ lift $ lift get + put = GhcModT . lift . lift . lift . put + state = GhcModT . lift . lift . lift . state + +#if MONADIO_INSTANCES +instance MonadIO m => MonadIO (StateT s m) where + liftIO = lift . liftIO + +instance MonadIO m => MonadIO (ReaderT r m) where + liftIO = lift . liftIO + +instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where + liftIO = lift . liftIO + +instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where + liftIO = lift . liftIO + +instance MonadIO m => MonadIO (MaybeT m) where + liftIO = lift . liftIO +#endif + + +instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where + liftBase = GhcModT . liftBase + +#if MIN_VERSION_monad_control(1,0,0) + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where + type StM (GhcModT m) a = + StM (StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) ) a + liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> + f $ runInBase . unGhcModT + + restoreM = GhcModT . restoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +#else + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where + newtype StM (GhcModT m) a = StGhcMod { + unStGhcMod :: StM (StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) ) a } + liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> + f $ liftM StGhcMod . runInBase . unGhcModT + + restoreM = GhcModT . restoreM . unStGhcMod + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +#endif + +-- GHC cannot prove the following instances to be decidable automatically using +-- the FlexibleContexts extension as they violate the second Paterson Condition, +-- namely that: The assertion has fewer constructors and variables (taken +-- together and counting repetitions) than the head. Specifically the +-- @MonadBaseControl IO m@ constraint is causing this violation. +-- +-- Proof of termination: +-- +-- Assuming all constraints containing the variable `m' exist and are decidable +-- we show termination by manually replacing the current set of constraints with +-- their own set of constraints and show that this, after a finite number of +-- steps, results in the empty set, i.e. not having to check any more +-- constraints. +-- +-- We start by setting the constraints to be those immediate constraints of the +-- instance declaration which cannot be proven decidable automatically for the +-- type under consideration. +-- +-- @ +-- { MonadBaseControl IO m } +-- @ +-- +-- Classes used: +-- +-- * @class MonadBase b m => MonadBaseControl b m@ +-- +-- @ +-- { MonadBase IO m } +-- @ +-- +-- Classes used: +-- +-- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@ +-- +-- @ +-- { Applicative IO, Applicative m, Monad IO, Monad m } +-- @ +-- +-- Classes used: +-- +-- * @class Monad m@ +-- * @class Applicative f => Functor f@ +-- +-- @ +-- { Functor m } +-- @ +-- +-- Classes used: +-- +-- * @class Functor f@ +-- +-- @ +-- { } +-- @ +-- ∎ + +instance (Functor m, MonadIO m, MonadBaseControl IO m) + => GhcMonad (GhcModT m) where + getSession = (liftIO . readIORef) . gmGhcSession =<< ask + setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask + +#if __GLASGOW_HASKELL__ >= 706 +instance (Functor m, MonadIO m, MonadBaseControl IO m) + => HasDynFlags (GhcModT m) where + getDynFlags = getSessionDynFlags +#endif + +instance (MonadIO m, MonadBaseControl IO m) + => ExceptionMonad (GhcModT m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index eac0775..68c75aa 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -1,14 +1,15 @@ {-# LANGUAGE BangPatterns, TupleSections #-} module Language.Haskell.GhcMod.PathsAndFiles where -import Config (cProjectVersion, cTargetPlatformString) +import Config (cProjectVersion) import Control.Applicative import Control.Monad import Data.List -import Data.List.Split (splitOn) import Data.Char import Data.Maybe import Data.Traversable (traverse) +import Distribution.System (buildPlatform) +import Distribution.Text (display) import Language.Haskell.GhcMod.Types import System.Directory import System.FilePath @@ -88,7 +89,6 @@ findCabalSandboxDir dir = do where isSandboxConfig = (=="cabal.sandbox.config") - appendDir :: DirPath -> [FileName] -> [FilePath] appendDir d fs = (d ) `map` fs @@ -164,6 +164,10 @@ ghcSandboxPkgDbDir = packageCache :: String packageCache = "package.cache" +-- | Filename of the show'ed Cabal setup-config cache +prettyConfigCache :: FilePath +prettyConfigCache = setupConfigPath <.> "ghc-mod-0.pretty-cabal-cache" + -- | Filename of the symbol table cache file. symbolCache :: Cradle -> FilePath symbolCache crdl = cradleTempDir crdl symbolCacheFile diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs index 83b874f..2779627 100644 --- a/Language/Haskell/GhcMod/World.hs +++ b/Language/Haskell/GhcMod/World.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards, CPP #-} module Language.Haskell.GhcMod.World where {-( , World @@ -12,7 +12,8 @@ import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils -import Control.Applicative (pure,(<$>),(<*>)) +import Control.Applicative (pure, (<$>), (<*>)) +import Control.Monad import Data.Maybe import Data.Traversable (traverse) import System.Directory (getModificationTime) @@ -45,6 +46,8 @@ data World = World { worldPackageCaches :: [TimedFile] , worldCabalFile :: Maybe TimedFile , worldCabalConfig :: Maybe TimedFile + , worldSymbolCache :: Maybe TimedFile + , worldPrettyCabalConfigCache :: Maybe TimedFile } deriving (Eq, Show) timedPackageCache :: Cradle -> IO [TimedFile] @@ -57,15 +60,23 @@ getCurrentWorld :: Cradle -> IO World getCurrentWorld crdl = do pkgCaches <- timedPackageCache crdl mCabalFile <- timeFile `traverse` cradleCabalFile crdl - mSetupConfig <- mightExist (setupConfigFile crdl) - mCabalConfig <- timeFile `traverse` mSetupConfig + mCabalConfig <- timeMaybe (setupConfigFile crdl) + mSymbolCache <- timeMaybe (symbolCache crdl) + mPrettyConfigCache <- timeMaybe prettyConfigCache return World { worldPackageCaches = pkgCaches , worldCabalFile = mCabalFile , worldCabalConfig = mCabalConfig + , worldSymbolCache = mSymbolCache + , worldPrettyCabalConfigCache = mPrettyConfigCache } + where + timeMaybe :: FilePath -> IO (Maybe TimedFile) + timeMaybe f = do + join $ (timeFile `traverse`) <$> mightExist f + didWorldChange :: World -> Cradle -> IO Bool didWorldChange world crdl = do (world /=) <$> getCurrentWorld crdl @@ -83,7 +94,11 @@ didWorldChange world crdl = do -- -- * Both files exist -- @Just cc < Just cf = cc < cf = cc `olderThan` cf@ -isSetupConfigOutOfDate :: Cradle -> IO Bool -isSetupConfigOutOfDate crdl = do - world <- getCurrentWorld crdl - return $ worldCabalConfig world < worldCabalFile world +isSetupConfigOutOfDate :: World -> Bool +isSetupConfigOutOfDate World {..} = do + worldCabalConfig < worldCabalFile + +isYoungerThanSetupConfig :: FilePath -> World -> IO Bool +isYoungerThanSetupConfig file World {..} = do + tfile <- timeFile file + return $ worldCabalConfig < Just tfile diff --git a/Setup.hs b/Setup.hs index cd6f34e..a53920c 100755 --- a/Setup.hs +++ b/Setup.hs @@ -130,7 +130,7 @@ sanityCheckCabalVersions args cf desc lbi = do minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10") when minGhc710 $ do - let cabalHelperCabalVer = compCabalVer CLibName + let cabalHelperCabalVer = compCabalVer (CExeName "cabal-helper") when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $ failCabalVersionDifferent cabalVer cabalHelperCabalVer diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 1fe41be..bd7c082 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -66,11 +66,13 @@ Library Default-Extensions: ConstraintKinds, FlexibleContexts Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Internal - Other-Modules: Language.Haskell.GhcMod.Boot + Other-Modules: Paths_ghc_mod + Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Browse Language.Haskell.GhcMod.CabalConfig.Cabal16 Language.Haskell.GhcMod.CabalConfig.Cabal18 - Language.Haskell.GhcMod.CabalConfig.Cabal21 + Language.Haskell.GhcMod.CabalConfig.Cabal22 + Language.Haskell.GhcMod.CabalConfig.Extract Language.Haskell.GhcMod.CabalConfig Language.Haskell.GhcMod.CabalApi Language.Haskell.GhcMod.CaseSplit @@ -91,8 +93,10 @@ Library Language.Haskell.GhcMod.Lang Language.Haskell.GhcMod.Lint Language.Haskell.GhcMod.Logger + Language.Haskell.GhcMod.Logging Language.Haskell.GhcMod.Modules Language.Haskell.GhcMod.Monad + Language.Haskell.GhcMod.Monad.Types Language.Haskell.GhcMod.PathsAndFiles Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.Read @@ -102,13 +106,9 @@ Library Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.World - if impl(ghc >= 7.10) - Other-Modules: Language.Haskell.GhcMod.CabalConfig.Ghc710 - else - Other-Modules: Language.Haskell.GhcMod.CabalConfig.PreGhc710 - Build-Depends: base >= 4.0 && < 5 + , bytestring , containers , deepseq , directory