Refactoring to use cabal-helper-wrapper
This turned out to be quite involved but save for this huge commit it's actually quite awesome and squashes quite a few bugs and nasty problems (hopefully). Most importantly we now have native cabal component support without the user having to do anything to get it! To do this we traverse imports starting from each component's entrypoints (library modules or Main source file for executables) and use this information to find which component's options each module will build with. Under the assumption that these modules have to build with every component they're used in we can now just pick one. Quite a few internal assumptions have been invalidated by this change. Most importantly the runGhcModT* family of cuntions now change the current working directory to `cradleRootDir`.
This commit is contained in:
Daniel Gröber
@@ -1,30 +1,30 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Logger (
|
||||
withLogger
|
||||
, withLogger'
|
||||
, checkErrorPrefix
|
||||
) where
|
||||
|
||||
import Bag (Bag, bagToList)
|
||||
import Control.Arrow
|
||||
import Control.Applicative ((<$>))
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
|
||||
import Exception (ghandle)
|
||||
import GHC (DynFlags, SrcSpan, Severity(SevError))
|
||||
import qualified GHC as G
|
||||
import HscTypes (SourceError, srcErrorMessages)
|
||||
import Language.Haskell.GhcMod.Doc (showPage, getStyle)
|
||||
import Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags)
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Convert (convert')
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Outputable (PprStyle, SDoc)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
|
||||
import System.FilePath (normalise)
|
||||
import Text.PrettyPrint
|
||||
|
||||
----------------------------------------------------------------
|
||||
import Bag (Bag, bagToList)
|
||||
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
|
||||
import GHC (DynFlags, SrcSpan, Severity(SevError))
|
||||
import HscTypes
|
||||
import Outputable
|
||||
import qualified GHC as G
|
||||
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Doc (showPage)
|
||||
import Language.Haskell.GhcMod.DynFlags (withDynFlags)
|
||||
import Language.Haskell.GhcMod.Monad.Types
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
|
||||
type Builder = [String] -> [String]
|
||||
|
||||
@@ -38,16 +38,16 @@ emptyLog = Log [] id
|
||||
newLogRef :: IO LogRef
|
||||
newLogRef = LogRef <$> newIORef emptyLog
|
||||
|
||||
readAndClearLogRef :: IOish m => LogRef -> GhcModT m String
|
||||
readAndClearLogRef :: LogRef -> IO [String]
|
||||
readAndClearLogRef (LogRef ref) = do
|
||||
Log _ b <- liftIO $ readIORef ref
|
||||
liftIO $ writeIORef ref emptyLog
|
||||
convert' (b [])
|
||||
Log _ b <- readIORef ref
|
||||
writeIORef ref emptyLog
|
||||
return $ b []
|
||||
|
||||
appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
|
||||
appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update
|
||||
appendLogRef df (LogRef ref) _ sev src st msg = modifyIORef ref update
|
||||
where
|
||||
l = ppMsg src sev df style msg
|
||||
l = ppMsg src sev df st msg
|
||||
update lg@(Log ls b)
|
||||
| l `elem` ls = lg
|
||||
| otherwise = Log (l:ls) (b . (l:))
|
||||
@@ -57,56 +57,68 @@ appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update
|
||||
-- | Set the session flag (e.g. "-Wall" or "-w:") then
|
||||
-- executes a body. Logged messages are returned as 'String'.
|
||||
-- Right is success and Left is failure.
|
||||
withLogger :: IOish m
|
||||
withLogger :: (GmGhc m, GmEnv m)
|
||||
=> (DynFlags -> DynFlags)
|
||||
-> GhcModT m ()
|
||||
-> GhcModT m (Either String String)
|
||||
withLogger setDF body = ghandle sourceError $ do
|
||||
logref <- liftIO newLogRef
|
||||
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
|
||||
withDynFlags (setLogger logref . setDF) $
|
||||
withCmdFlags wflags $ do
|
||||
body
|
||||
Right <$> readAndClearLogRef logref
|
||||
-> m a
|
||||
-> m (Either String (String, a))
|
||||
withLogger f action = do
|
||||
env <- G.getSession
|
||||
opts <- options
|
||||
let conv = convert opts
|
||||
eres <- withLogger' env $ \setDf ->
|
||||
withDynFlags (f . setDf) action
|
||||
return $ either (Left . conv) (Right . first conv) eres
|
||||
|
||||
withLogger' :: IOish m
|
||||
=> HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))
|
||||
withLogger' env action = do
|
||||
logref <- liftIO $ newLogRef
|
||||
|
||||
let dflags = hsc_dflags env
|
||||
pu = icPrintUnqual dflags (hsc_IC env)
|
||||
st = mkUserStyle pu AllTheWay
|
||||
|
||||
fn df = setLogger logref df
|
||||
|
||||
a <- gcatches (Right <$> action fn) (handlers dflags st)
|
||||
ls <- liftIO $ readAndClearLogRef logref
|
||||
|
||||
return $ ((,) ls <$> a)
|
||||
|
||||
where
|
||||
setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
|
||||
handlers df st = [
|
||||
GHandler $ \ex -> return $ Left $ sourceError df st ex,
|
||||
GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
|
||||
]
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Converting 'SourceError' to 'String'.
|
||||
sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
|
||||
sourceError err = errBagToStr (srcErrorMessages err)
|
||||
|
||||
errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String)
|
||||
errBagToStr = errBagToStr' Left
|
||||
|
||||
errBagToStr' :: IOish m => (String -> a) -> Bag ErrMsg -> GhcModT m a
|
||||
errBagToStr' f err = do
|
||||
dflags <- G.getSessionDynFlags
|
||||
style <- getStyle
|
||||
ret <- convert' (errBagToStrList dflags style err)
|
||||
return $ f ret
|
||||
sourceError :: DynFlags -> PprStyle -> SourceError -> [String]
|
||||
sourceError df st src_err = errBagToStrList df st $ srcErrorMessages src_err
|
||||
|
||||
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
|
||||
errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
|
||||
errBagToStrList df st = map (ppErrMsg df st) . reverse . bagToList
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
|
||||
ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ (if null ext then "" else "\n" ++ ext)
|
||||
ppErrMsg dflag st err =
|
||||
ppMsg spn SevError dflag st msg ++ (if null ext then "" else "\n" ++ ext)
|
||||
where
|
||||
spn = Gap.errorMsgSpan err
|
||||
msg = errMsgShortDoc err
|
||||
ext = showPage dflag style (errMsgExtraInfo err)
|
||||
ext = showPage dflag st (errMsgExtraInfo err)
|
||||
|
||||
ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
|
||||
ppMsg spn sev dflag style msg = prefix ++ cts
|
||||
ppMsg spn sev dflag st msg = prefix ++ cts
|
||||
where
|
||||
cts = showPage dflag style msg
|
||||
prefix = ppMsgPrefix spn sev dflag style cts
|
||||
cts = showPage dflag st msg
|
||||
prefix = ppMsgPrefix spn sev dflag st cts
|
||||
|
||||
ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String
|
||||
ppMsgPrefix spn sev dflag _style cts =
|
||||
ppMsgPrefix spn sev dflag _st cts =
|
||||
let defaultPrefix
|
||||
| Gap.isDumpSplices dflag = ""
|
||||
| otherwise = checkErrorPrefix
|
||||
|
||||
Reference in New Issue
Block a user