diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index 66c7b71..f30a48d 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -34,8 +34,7 @@ check :: IOish m => [FilePath] -- ^ The target files. -> GhcModT m (Either String String) check fileNames = do - withLogger setAllWaringFlags $ do - setTargetFiles fileNames + withLogger setAllWaringFlags $ setTargetFiles fileNames ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs index 78927b2..7cbbd4d 100644 --- a/Language/Haskell/GhcMod/DynFlags.hs +++ b/Language/Haskell/GhcMod/DynFlags.hs @@ -4,11 +4,12 @@ import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types import Control.Applicative ((<$>)) -import Control.Monad (forM, void) +import Control.Monad (forM, void, (>=>)) import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..), LoadHowMuch(..)) import qualified GHC as G import GhcMonad import GHC.Paths (libdir) +import DynFlags (ExtensionFlag(..), xopt) import System.IO.Unsafe (unsafePerformIO) @@ -17,11 +18,23 @@ data Build = CabalPkg | SingleFile deriving Eq setEmptyLogger :: DynFlags -> DynFlags setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return () --- we don't want to generate object code so we compile to bytecode --- (HscInterpreted) which implies LinkInMemory --- HscInterpreted -setLinkerOptions :: DynFlags -> DynFlags -setLinkerOptions df = df { +-- Fast +-- Friendly to foreign export +-- Not friendly to Template Haskell +-- Uses small memory +setModeSimple :: DynFlags -> DynFlags +setModeSimple df = df { + ghcMode = CompManager + , ghcLink = NoLink + , hscTarget = HscNothing + } + +-- Slow +-- Not friendly to foreign export +-- Friendly to Template Haskell +-- Uses large memory +setModeIntelligent :: DynFlags -> DynFlags +setModeIntelligent df = df { ghcMode = CompManager , ghcLink = LinkInMemory , hscTarget = HscInterpreted @@ -59,7 +72,28 @@ setTargetFiles :: (GhcMonad m) => [FilePath] -> m () setTargetFiles files = do targets <- forM files $ \file -> G.guessTarget file Nothing G.setTargets targets - void $ G.load LoadAllTargets + xs <- G.depanal [] False + -- FIXME, checking state + loadTargets $ needsFallback xs + where + loadTargets False = do + -- Reporting error A and error B + void $ G.load LoadAllTargets + mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph + -- Reporting error B and error C + mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss + -- Error B duplicates. But we cannot ignore both error reportings, + -- sigh. So, the logger makes log messages unique by itself. + loadTargets True = do + df <- G.getSessionDynFlags + void $ G.setSessionDynFlags (setModeIntelligent df) + void $ G.load LoadAllTargets + +needsFallback :: G.ModuleGraph -> Bool +needsFallback = any (hasTHorQQ . G.ms_hspp_opts) + where + hasTHorQQ :: DynFlags -> Bool + hasTHorQQ dflags = any (`xopt` dflags) [Opt_TemplateHaskell, Opt_QuasiQuotes] ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 175bdbf..6f9ce6c 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -6,7 +6,7 @@ module Language.Haskell.GhcMod.Logger ( ) where import Bag (Bag, bagToList) -import Control.Applicative ((<$>),(*>)) +import Control.Applicative ((<$>)) import CoreMonad (liftIO) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.List (isPrefixOf) @@ -28,21 +28,29 @@ import System.FilePath (normalise) type Builder = [String] -> [String] -newtype LogRef = LogRef (IORef Builder) +data Log = Log [String] Builder + +newtype LogRef = LogRef (IORef Log) + +emptyLog :: Log +emptyLog = Log [] id newLogRef :: IO LogRef -newLogRef = LogRef <$> newIORef id +newLogRef = LogRef <$> newIORef emptyLog readAndClearLogRef :: IOish m => LogRef -> GhcModT m String readAndClearLogRef (LogRef ref) = do - b <- liftIO $ readIORef ref - liftIO $ writeIORef ref id + Log _ b <- liftIO $ readIORef ref + liftIO $ writeIORef ref emptyLog convert' (b []) appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () -appendLogRef df (LogRef ref) _ sev src style msg = do - let !l = ppMsg src sev df style msg - modifyIORef ref (\b -> b . (l:)) +appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update + where + l = ppMsg src sev df style msg + update lg@(Log ls b) + | l `elem` ls = lg + | otherwise = Log (l:ls) (b . (l:)) ---------------------------------------------------------------- @@ -57,7 +65,9 @@ withLogger setDF body = ghandle sourceError $ do logref <- liftIO $ newLogRef wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options withDynFlags (setLogger logref . setDF) $ do - withCmdFlags wflags $ do body *> (Right <$> readAndClearLogRef logref) + withCmdFlags wflags $ do + body + Right <$> readAndClearLogRef logref where setLogger logref df = Gap.setLogAction df $ appendLogRef df logref diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index ebcc7cc..02e9df4 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -189,7 +189,7 @@ initSession :: GhcMonad m initSession build Options {..} CompilerOptions {..} = do df <- G.getSessionDynFlags void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions - $ setLinkerOptions + $ setModeSimple $ setIncludeDirs includeDirs $ setBuildEnv build $ setEmptyLogger