diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index 83571b4..223123e 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -28,7 +28,7 @@ check :: Options -> Cradle -> FilePath -- ^ A target file -> Ghc [String] -check opt cradle fileName = checkIt `gcatch` handleErrMsg +check opt cradle fileName = checkIt `gcatch` handleErrMsg ls where checkIt = do readLog <- initializeFlagsWithCradle opt cradle options True @@ -39,3 +39,4 @@ check opt cradle fileName = checkIt `gcatch` handleErrMsg options | expandSplice opt = "-w:" : ghcOpts opt | otherwise = "-Wall" : ghcOpts opt + ls = lineSeparator opt diff --git a/Language/Haskell/GhcMod/ErrMsg.hs b/Language/Haskell/GhcMod/ErrMsg.hs index 5a2e485..dde3ce6 100644 --- a/Language/Haskell/GhcMod/ErrMsg.hs +++ b/Language/Haskell/GhcMod/ErrMsg.hs @@ -15,6 +15,7 @@ import ErrUtils import GHC import HscTypes import Language.Haskell.GhcMod.Doc (showUnqualifiedPage) +import Language.Haskell.GhcMod.Types (LineSeparator(..)) import qualified Language.Haskell.GhcMod.Gap as Gap import Outputable import System.FilePath (normalise) @@ -26,42 +27,42 @@ type LogReader = IO [String] ---------------------------------------------------------------- -setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader) -setLogger False df = return (newdf, undefined) +setLogger :: Bool -> DynFlags -> LineSeparator -> IO (DynFlags, LogReader) +setLogger False df _ = return (newdf, undefined) where newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return () -setLogger True df = do +setLogger True df ls = do ref <- newIORef [] :: IO (IORef [String]) let newdf = Gap.setLogAction df $ appendLog ref return (newdf, reverse <$> readIORef ref) where appendLog ref _ sev src _ msg = do - let !l = ppMsg src sev df msg - modifyIORef ref (\ls -> l : ls) + let !l = ppMsg src sev df ls msg + modifyIORef ref (l:) ---------------------------------------------------------------- -handleErrMsg :: SourceError -> Ghc [String] -handleErrMsg err = do +handleErrMsg :: LineSeparator -> SourceError -> Ghc [String] +handleErrMsg ls err = do dflag <- getSessionDynFlags - return . errBagToStrList dflag . srcErrorMessages $ err + return . errBagToStrList dflag ls . srcErrorMessages $ err -errBagToStrList :: DynFlags -> Bag ErrMsg -> [String] -errBagToStrList dflag = map (ppErrMsg dflag) . reverse . bagToList +errBagToStrList :: DynFlags -> LineSeparator -> Bag ErrMsg -> [String] +errBagToStrList dflag ls = map (ppErrMsg dflag ls) . reverse . bagToList ---------------------------------------------------------------- -ppErrMsg :: DynFlags -> ErrMsg -> String -ppErrMsg dflag err = ppMsg spn SevError dflag msg ++ ext +ppErrMsg :: DynFlags -> LineSeparator -> ErrMsg -> String +ppErrMsg dflag ls err = ppMsg spn SevError dflag ls msg ++ ext where spn = head (errMsgSpans err) msg = errMsgShortDoc err - ext = showMsg dflag (errMsgExtraInfo err) + ext = showMsg dflag ls (errMsgExtraInfo err) -ppMsg :: SrcSpan -> Severity-> DynFlags -> SDoc -> String -ppMsg spn sev dflag msg = prefix ++ cts ++ "\0" +ppMsg :: SrcSpan -> Severity-> DynFlags -> LineSeparator -> SDoc -> String +ppMsg spn sev dflag ls@(LineSeparator lsep) msg = prefix ++ cts ++ lsep where - cts = showMsg dflag msg + cts = showMsg dflag ls msg defaultPrefix | dopt Opt_D_dump_splices dflag = "" | otherwise = "Dummy:0:0:" @@ -73,8 +74,15 @@ ppMsg spn sev dflag msg = prefix ++ cts ++ "\0" ---------------------------------------------------------------- -showMsg :: DynFlags -> SDoc -> String -showMsg dflag sdoc = map toNull $ showUnqualifiedPage dflag sdoc +showMsg :: DynFlags -> LineSeparator -> SDoc -> String +showMsg dflag (LineSeparator [s]) sdoc = replaceNull $ showUnqualifiedPage dflag sdoc where - toNull '\n' = '\0' - toNull x = x + replaceNull :: String -> String + replaceNull [] = [] + replaceNull ('\n':xs) = s : replaceNull xs + replaceNull (x:xs) = x : replaceNull xs +showMsg dflag (LineSeparator lsep) sdoc = replaceNull $ showUnqualifiedPage dflag sdoc + where + replaceNull [] = [] + replaceNull ('\n':xs) = lsep ++ replaceNull xs + replaceNull (x:xs) = x : replaceNull xs diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs index 197b131..4fac7a8 100644 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/Language/Haskell/GhcMod/GHCApi.hs @@ -87,11 +87,12 @@ initSession build opt cmdOpts idirs mDepPkgs logging = do _ <- setSessionDynFlags dflags1 return readLog where + ls = lineSeparator opt setupDynamicFlags df0 = do df1 <- modifyFlagsWithOpts df0 cmdOpts let df2 = modifyFlags df1 idirs mDepPkgs (expandSplice opt) build df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt - liftIO $ setLogger logging df3 + liftIO $ setLogger logging df3 ls ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs index 6a44c36..7d3eb8c 100644 --- a/Language/Haskell/GhcMod/Lint.hs +++ b/Language/Haskell/GhcMod/Lint.hs @@ -12,7 +12,8 @@ lintSyntax :: Options -> IO String lintSyntax opt file = pack <$> lint opt file where - pack = unlines . map (intercalate "\0" . lines) + LineSeparator lsep = lineSeparator opt + pack = unlines . map (intercalate lsep . lines) lint :: Options -> FilePath -- ^ A target file. diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 6179f6a..d050930 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -6,29 +6,33 @@ module Language.Haskell.GhcMod.Types where data OutputStyle = LispStyle -- ^ S expression style | PlainStyle -- ^ Plain textstyle +newtype LineSeparator = LineSeparator String + data Options = Options { - outputStyle :: OutputStyle - , hlintOpts :: [String] - , ghcOpts :: [String] - , operators :: Bool + outputStyle :: OutputStyle + , hlintOpts :: [String] + , ghcOpts :: [String] + , operators :: Bool -- | If 'True', 'browse' also returns types. - , detailed :: Bool + , detailed :: Bool -- | Whether or not Template Haskell should be expanded. - , expandSplice :: Bool + , expandSplice :: Bool -- | The sandbox directory. - , sandbox :: Maybe FilePath + , sandbox :: Maybe FilePath + , lineSeparator :: LineSeparator } -- | A default 'Options'. defaultOptions :: Options defaultOptions = Options { - outputStyle = PlainStyle - , hlintOpts = [] - , ghcOpts = [] - , operators = False - , detailed = False - , expandSplice = False - , sandbox = Nothing + outputStyle = PlainStyle + , hlintOpts = [] + , ghcOpts = [] + , operators = False + , detailed = False + , expandSplice = False + , sandbox = Nothing + , lineSeparator = LineSeparator "\0" } ----------------------------------------------------------------