diff --git a/CabalApi.hs b/CabalApi.hs index 3f17fab..c622238 100644 --- a/CabalApi.hs +++ b/CabalApi.hs @@ -5,14 +5,13 @@ module CabalApi ( , cabalParseFile , cabalBuildInfo , cabalAllDependPackages - , cabalAllExtentions , getGHCVersion ) where import Control.Applicative import Control.Exception (throwIO) import Data.List (intercalate) -import Data.Maybe (fromJust, maybeToList, mapMaybe) +import Data.Maybe (fromJust, maybeToList) import Data.Set (fromList, toList) import Distribution.Package (Dependency(Dependency), PackageName(PackageName)) import Distribution.PackageDescription @@ -22,7 +21,6 @@ import Distribution.Simple.Program.Types (programName, programFindVersion) import Distribution.Text (display) import Distribution.Verbosity (silent) import Distribution.Version (versionBranch) -import Language.Haskell.Extension (Extension(..)) import System.FilePath import Types @@ -30,15 +28,15 @@ import Types fromCabalFile :: [GHCOption] -> Cradle - -> IO ([GHCOption],[IncludeDir],[Package],[LangExt]) + -> IO ([GHCOption],[IncludeDir],[Package]) fromCabalFile ghcOptions cradle = cookInfo ghcOptions cradle <$> cabalParseFile cfile where Just cfile = cradleCabalFile cradle cookInfo :: [String] -> Cradle -> GenericPackageDescription - -> ([GHCOption],[IncludeDir],[Package],[LangExt]) -cookInfo ghcOptions cradle cabal = (gopts,idirs,depPkgs,hdrExts) + -> ([GHCOption],[IncludeDir],[Package]) +cookInfo ghcOptions cradle cabal = (gopts,idirs,depPkgs) where owdir = cradleCurrentDir cradle Just cdir = cradleCabalDir cradle @@ -47,7 +45,6 @@ cookInfo ghcOptions cradle cabal = (gopts,idirs,depPkgs,hdrExts) gopts = getGHCOptions ghcOptions binfo idirs = includeDirectroies cdir owdir $ hsSourceDirs binfo depPkgs = removeMe cfile $ cabalAllDependPackages cabal - hdrExts = cabalAllExtentions cabal removeMe :: FilePath -> [String] -> [String] removeMe cabalfile = filter (/= me) @@ -98,30 +95,6 @@ getDependencyPackageName (Dependency (PackageName nm) _) = nm ---------------------------------------------------------------- -cabalAllExtentions :: GenericPackageDescription -> [LangExt] -cabalAllExtentions pd = uniqueAndSort exts - where - buildInfos = cabalAllBuildInfos pd - eexts = concatMap oldExtensions buildInfos - ++ concatMap defaultExtensions buildInfos - exts = mapMaybe getExtensionName eexts - -getExtensionName :: Extension -> Maybe LangExt -getExtensionName (EnableExtension nm) = Just (display nm) -getExtensionName _ = Nothing - ----------------------------------------------------------------- - -cabalAllBuildInfos :: GenericPackageDescription -> [BuildInfo] -cabalAllBuildInfos = fromPackageDescription f1 f2 f3 f4 - where - f1 = map (libBuildInfo . condTreeData) - f2 = map (buildInfo . condTreeData) - f3 = map (testBuildInfo . condTreeData) - f4 = map (benchmarkBuildInfo . condTreeData) - ----------------------------------------------------------------- - type Tree = CondTree ConfVar [Dependency] fromPackageDescription :: ([Tree Library] -> [a]) diff --git a/Check.hs b/Check.hs index 4dff144..24fd974 100644 --- a/Check.hs +++ b/Check.hs @@ -1,6 +1,7 @@ module Check (checkSyntax) where import Control.Applicative +import Control.Monad import CoreMonad import ErrMsg import Exception @@ -20,9 +21,11 @@ check :: Options -> Cradle -> String -> IO [String] check opt cradle fileName = withGHC fileName $ checkIt `gcatch` handleErrMsg where checkIt = do - readLog <- initializeFlagsWithCradle opt cradle fileName options True + readLog <- initializeFlagsWithCradle opt cradle options True setTargetFile fileName - _ <- load LoadAllTargets + slow <- needsTemplateHaskell <$> depanal [] False + when slow setSlowDynFlags + void $ load LoadAllTargets liftIO readLog options | expandSplice opt = "-w:" : ghcOpts opt diff --git a/Debug.hs b/Debug.hs index 832bda2..2bf8626 100644 --- a/Debug.hs +++ b/Debug.hs @@ -1,10 +1,12 @@ module Debug (debugInfo) where import CabalApi -import GHCApi import Control.Applicative +import Control.Monad import Data.List (intercalate) import Data.Maybe +import GHC +import GHCApi import Prelude import Types @@ -15,13 +17,16 @@ debugInfo opt cradle ver fileName = unlines <$> debug opt cradle ver fileName debug :: Options -> Cradle -> String -> String -> IO [String] debug opt cradle ver fileName = do - (gopts, incDir, pkgs, langext) <- + (gopts, incDir, pkgs) <- if cabal then fromCabalFile (ghcOpts opt) cradle else - return (ghcOpts opt, [], [], []) - dflags <- getDynamicFlags - fast <- getFastCheck dflags fileName (Just langext) + return (ghcOpts opt, [], []) + [fast] <- withGHC fileName $ do + void $ initializeFlagsWithCradle opt cradle gopts True + setTargetFile fileName + slow <- needsTemplateHaskell <$> depanal [] False + return [not slow] return [ "GHC version: " ++ ver , "Current directory: " ++ currentDir diff --git a/GHCApi.hs b/GHCApi.hs index 4a16ab6..c34448f 100644 --- a/GHCApi.hs +++ b/GHCApi.hs @@ -5,7 +5,7 @@ module GHCApi ( , initializeFlagsWithCradle , setTargetFile , getDynamicFlags - , getFastCheck + , setSlowDynFlags ) where import CabalApi @@ -19,7 +19,6 @@ import ErrMsg import Exception import GHC import GHC.Paths (libdir) -import HeaderInfo import System.Exit import System.IO import Types @@ -45,13 +44,13 @@ withGHC file body = ghandle ignore $ runGhc (Just libdir) $ do importDirs :: [IncludeDir] importDirs = [".","..","../..","../../..","../../../..","../../../../.."] -initializeFlagsWithCradle :: Options -> Cradle -> FilePath -> [GHCOption] -> Bool -> Ghc LogReader -initializeFlagsWithCradle opt cradle fileName ghcOptions logging +initializeFlagsWithCradle :: Options -> Cradle -> [GHCOption] -> Bool -> Ghc LogReader +initializeFlagsWithCradle opt cradle ghcOptions logging | cabal = do - (gopts,idirs,depPkgs,hdrExts) <- liftIO $ fromCabalFile ghcOptions cradle - initSession opt gopts idirs (Just depPkgs) (Just hdrExts) logging fileName + (gopts,idirs,depPkgs) <- liftIO $ fromCabalFile ghcOptions cradle + initSession opt gopts idirs (Just depPkgs) logging | otherwise = - initSession opt ghcOptions importDirs Nothing Nothing logging fileName + initSession opt ghcOptions importDirs Nothing logging where cabal = isJust $ cradleCabalFile cradle @@ -61,11 +60,9 @@ initSession :: Options -> [GHCOption] -> [IncludeDir] -> Maybe [Package] - -> Maybe [LangExt] -> Bool - -> FilePath -> Ghc LogReader -initSession opt cmdOpts idirs mDepPkgs mLangExts logging file = do +initSession opt cmdOpts idirs mDepPkgs logging = do dflags0 <- getSessionDynFlags (dflags1,readLog) <- setupDynamicFlags dflags0 _ <- setSessionDynFlags dflags1 @@ -73,7 +70,7 @@ initSession opt cmdOpts idirs mDepPkgs mLangExts logging file = do where setupDynamicFlags df0 = do df1 <- modifyFlagsWithOpts df0 cmdOpts - fast <- liftIO $ getFastCheck df0 file mLangExts + let fast = True let df2 = modifyFlags df1 idirs mDepPkgs fast (expandSplice opt) df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt liftIO $ setLogger logging df3 @@ -88,24 +85,6 @@ initializeFlags opt = do ---------------------------------------------------------------- -getHeaderExtension :: DynFlags -> FilePath -> IO [HeaderExt] -getHeaderExtension dflags file = map unLoc <$> getOptionsFromFile dflags file - ----------------------------------------------------------------- - -getFastCheck :: DynFlags -> FilePath -> Maybe [LangExt] -> IO Bool -getFastCheck dflags file mLangExts = do - hdrExts <- getHeaderExtension dflags file - return . not $ useTemplateHaskell mLangExts hdrExts - -useTemplateHaskell :: Maybe [LangExt] -> [HeaderExt] -> Bool -useTemplateHaskell mLangExts hdrExts = th1 || th2 - where - th1 = "-XTemplateHaskell" `elem` hdrExts - th2 = maybe False ("TemplateHaskell" `elem`) mLangExts - ----------------------------------------------------------------- - -- FIXME removing Options modifyFlags :: DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> Bool -> DynFlags modifyFlags d0 idirs mDepPkgs fast splice @@ -119,6 +98,16 @@ modifyFlags d0 idirs mDepPkgs fast splice setSplice :: DynFlags -> DynFlags setSplice dflag = dopt_set dflag Opt_D_dump_splices +addDevPkgs :: DynFlags -> [Package] -> DynFlags +addDevPkgs df pkgs = df'' + where + df' = dopt_set df Opt_HideAllPackages + df'' = df' { + packageFlags = map ExposePackage pkgs ++ packageFlags df + } + +---------------------------------------------------------------- + setFastOrNot :: DynFlags -> Bool -> DynFlags setFastOrNot dflags False = dflags { ghcLink = LinkInMemory @@ -129,13 +118,9 @@ setFastOrNot dflags True = dflags { , hscTarget = HscNothing } -addDevPkgs :: DynFlags -> [Package] -> DynFlags -addDevPkgs df pkgs = df'' - where - df' = dopt_set df Opt_HideAllPackages - df'' = df' { - packageFlags = map ExposePackage pkgs ++ packageFlags df - } +setSlowDynFlags :: Ghc () +setSlowDynFlags = (flip setFastOrNot False <$> getSessionDynFlags) + >>= void . setSessionDynFlags ---------------------------------------------------------------- diff --git a/Info.hs b/Info.hs index 73b7962..018cef6 100644 --- a/Info.hs +++ b/Info.hs @@ -143,12 +143,12 @@ inModuleContext opt cradle fileName modstr action errmsg = withGHCDummyFile (valid ||> invalid ||> return errmsg) where valid = do - _ <- initializeFlagsWithCradle opt cradle fileName ["-w"] False + _ <- initializeFlagsWithCradle opt cradle ["-w"] False setTargetFile fileName _ <- load LoadAllTargets doif setContextFromTarget action invalid = do - _ <- initializeFlagsWithCradle opt cradle fileName ["-w"] False + _ <- initializeFlagsWithCradle opt cradle ["-w"] False setTargetBuffer _ <- load LoadAllTargets doif setContextFromTarget action diff --git a/Types.hs b/Types.hs index d39a068..d9944a6 100644 --- a/Types.hs +++ b/Types.hs @@ -76,5 +76,3 @@ data Cradle = Cradle { type GHCOption = String type IncludeDir = FilePath type Package = String -type LangExt = String -type HeaderExt = String \ No newline at end of file