diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2013-09-04 v2.1.2 + * Supporting multiple target files. (@nh2) + +2013-09-03 v2.1.1 + * A bug fix for library dependency. + +2013-09-03 v2.1.0 + * Exporting Language.Haskell.GhcMod.Internal. (@alanz) + * Supporting GHC 7.7. (@co-dan) + 2013-05-30 v2.0.3 * Using finalizePackageDescription to enable "if else" in a cabal file. diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -9,6 +9,7 @@ , getGHCVersion -- * Options , Options(..) + , LineSeparator(..) , OutputStyle(..) , defaultOptions -- * Types diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -16,9 +16,14 @@ -- Warnings and errors are returned. checkSyntax :: Options -> Cradle - -> FilePath -- ^ A target file + -> [FilePath] -- ^ The target files -> IO String -checkSyntax opt cradle file = unlines <$> withGHC file (check opt cradle file) +checkSyntax _ _ [] = error "ghc-mod: checkSyntax: No files given" +checkSyntax opt cradle files = unlines <$> withGHC sessionName (check opt cradle files) + where + sessionName = case files of + [file] -> file + _ -> "MultipleFiles" ---------------------------------------------------------------- @@ -26,16 +31,18 @@ -- Warnings and errors are returned. check :: Options -> Cradle - -> FilePath -- ^ A target file + -> [FilePath] -- ^ The target files -> Ghc [String] -check opt cradle fileName = checkIt `gcatch` handleErrMsg +check _ _ [] = error "ghc-mod: check: No files given" +check opt cradle fileNames = checkIt `gcatch` handleErrMsg ls where checkIt = do readLog <- initializeFlagsWithCradle opt cradle options True - setTargetFile fileName + setTargetFiles fileNames checkSlowAndSet void $ load LoadAllTargets liftIO readLog options | expandSplice opt = "-w:" : ghcOpts opt | otherwise = "-Wall" : ghcOpts opt + ls = lineSeparator opt diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -36,7 +36,7 @@ return (ghcOpts opt, [], []) [fast] <- do void $ initializeFlagsWithCradle opt cradle gopts True - setTargetFile fileName + setTargetFiles [fileName] pure . canCheckFast <$> depanal [] False return [ "GHC version: " ++ ver diff --git a/Language/Haskell/GhcMod/ErrMsg.hs b/Language/Haskell/GhcMod/ErrMsg.hs --- a/Language/Haskell/GhcMod/ErrMsg.hs +++ b/Language/Haskell/GhcMod/ErrMsg.hs @@ -15,6 +15,7 @@ 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 @@ ---------------------------------------------------------------- -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 @@ ---------------------------------------------------------------- -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 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/Language/Haskell/GhcMod/GHCApi.hs @@ -5,7 +5,7 @@ , withGHCDummyFile , initializeFlags , initializeFlagsWithCradle - , setTargetFile + , setTargetFiles , getDynamicFlags , setSlowDynFlags , checkSlowAndSet @@ -87,11 +87,12 @@ _ <- 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 ---------------------------------------------------------------- @@ -153,11 +154,12 @@ ---------------------------------------------------------------- --- | Set the file that GHC will load / compile -setTargetFile :: (GhcMonad m) => String -> m () -setTargetFile file = do - target <- guessTarget file Nothing - setTargets [target] +-- | Set the files that GHC will load / compile +setTargetFiles :: (GhcMonad m) => [String] -> m () +setTargetFiles [] = error "ghc-mod: setTargetFiles: No target files given" +setTargetFiles files = do + targets <- forM files $ \file -> guessTarget file Nothing + setTargets targets ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -148,7 +148,7 @@ valid = do void $ initializeFlagsWithCradle opt cradle ["-w:"] False when (cmd == Info) setSlowDynFlags - setTargetFile file + setTargetFiles [file] checkSlowAndSet void $ load LoadAllTargets doif setContextFromTarget action diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -5,7 +5,7 @@ LogReader , GHCOption , initializeFlagsWithCradle - , setTargetFile + , setTargetFiles , checkSlowAndSet , getDynamicFlags ) where diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs --- a/Language/Haskell/GhcMod/Lint.hs +++ b/Language/Haskell/GhcMod/Lint.hs @@ -12,7 +12,8 @@ -> 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 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -6,29 +6,33 @@ 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" } ---------------------------------------------------------------- diff --git a/ghc-mod.cabal b/ghc-mod.cabal --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 2.1.1 +Version: 2.1.2 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 diff --git a/src/GHCMod.hs b/src/GHCMod.hs --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -4,6 +4,7 @@ import Control.Applicative import Control.Exception +import Control.Monad import Data.Typeable import Data.Version import Language.Haskell.GhcMod @@ -12,6 +13,7 @@ import System.Console.GetOpt import System.Directory import System.Environment (getArgs) +import System.Exit (exitFailure) import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8) ---------------------------------------------------------------- @@ -26,8 +28,8 @@ ++ "\t ghc-mod lang [-l]\n" ++ "\t ghc-mod flag [-l]\n" ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [ ...]\n" - ++ "\t ghc-mod check" ++ ghcOptHelp ++ "\n" - ++ "\t ghc-mod expand" ++ ghcOptHelp ++ "\n" + ++ "\t ghc-mod check" ++ ghcOptHelp ++ "\n" + ++ "\t ghc-mod expand" ++ ghcOptHelp ++ "\n" ++ "\t ghc-mod debug" ++ ghcOptHelp ++ "\n" ++ "\t ghc-mod info" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod type" ++ ghcOptHelp ++ " \n" @@ -56,6 +58,9 @@ , Option "s" ["sandbox"] (ReqArg (\s opts -> opts { sandbox = Just s }) "path") "specify cabal-dev sandbox (default 'cabal-dev`)" + , Option "b" ["boundary"] + (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep") + "specify line separator (default is Nul string)" ] parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) @@ -67,6 +72,7 @@ ---------------------------------------------------------------- data GHCModError = SafeList + | TooManyArguments String | NoSuchCommand String | CmdArg [String] | FileNotExist String deriving (Show, Typeable) @@ -90,15 +96,19 @@ cmdArg2 = cmdArg !. 2 cmdArg3 = cmdArg !. 3 cmdArg4 = cmdArg !. 4 + remainingArgs = tail cmdArg + nArgs n f = if length remainingArgs == n + then f + else throw (TooManyArguments cmdArg0) res <- case cmdArg0 of - "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg) + "browse" -> concat <$> mapM (browseModule opt) remainingArgs "list" -> listModules opt - "check" -> checkSyntax opt cradle cmdArg1 - "expand" -> checkSyntax opt { expandSplice = True } cradle cmdArg1 - "debug" -> debugInfo opt cradle strVer cmdArg1 - "type" -> typeExpr opt cradle cmdArg1 cmdArg2 (read cmdArg3) (read cmdArg4) - "info" -> infoExpr opt cradle cmdArg1 cmdArg2 cmdArg3 - "lint" -> withFile (lintSyntax opt) cmdArg1 + "check" -> checkSyntax opt cradle remainingArgs + "expand" -> checkSyntax opt { expandSplice = True } cradle remainingArgs + "debug" -> nArgs 1 $ debugInfo opt cradle strVer cmdArg1 + "type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 cmdArg2 (read cmdArg3) (read cmdArg4) + "info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg2 cmdArg3 + "lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1 "lang" -> listLanguages opt "flag" -> listFlags opt "boot" -> do @@ -107,14 +117,19 @@ flags <- listFlags opt pre <- concat <$> mapM (browseModule opt) preBrowsedModules return $ mods ++ langs ++ flags ++ pre + "help" -> return $ usageInfo usage argspec cmd -> throw (NoSuchCommand cmd) putStr res where - handlers = [Handler handler1, Handler handler2] + handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)] + handleThenExit handler = \e -> handler e >> exitFailure handler1 :: ErrorCall -> IO () handler1 = print -- for debug handler2 :: GHCModError -> IO () handler2 SafeList = printUsage + handler2 (TooManyArguments cmd) = do + hPutStrLn stderr $ "\"" ++ cmd ++ "\": Too many arguments" + printUsage handler2 (NoSuchCommand cmd) = do hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported" printUsage diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -11,7 +11,7 @@ spec = do describe "parseCabalFile" $ do it "throws an exception if the cabal file is broken" $ do - parseCabalFile "test/data/broken-cabal/broken.cabal" `shouldThrow` (\(e::IOException) -> True) + parseCabalFile "test/data/broken-cabal/broken.cabal" `shouldThrow` (\(_::IOException) -> True) describe "cabalAllDependPackages" $ do it "extracts dependent packages" $ do diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -14,24 +14,24 @@ withDirectory_ "test/data/ghc-mod-check" $ do (strVer,_) <- getGHCVersion cradle <- findCradle Nothing strVer - res <- checkSyntax defaultOptions cradle "main.hs" + res <- checkSyntax defaultOptions cradle ["main.hs"] res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\NUL\n" it "can check even if a test module imports another test module located at different directory" $ do withDirectory_ "test/data/check-test-subdir" $ do cradle <- getGHCVersion >>= findCradle Nothing . fst - res <- checkSyntax defaultOptions cradle "test/Bar/Baz.hs" + res <- checkSyntax defaultOptions cradle ["test/Bar/Baz.hs"] res `shouldSatisfy` (("test" "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\NUL\n") `isSuffixOf`) it "can detect mutually imported modules" $ do withDirectory_ "test/data" $ do (strVer,_) <- getGHCVersion cradle <- findCradle Nothing strVer - res <- checkSyntax defaultOptions cradle "Mutual1.hs" + res <- checkSyntax defaultOptions cradle ["Mutual1.hs"] res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`) it "can check a module using QuasiQuotes" $ do withDirectory_ "test/data" $ do cradle <- getGHCVersion >>= findCradle Nothing . fst - res <- checkSyntax defaultOptions cradle "Baz.hs" + res <- checkSyntax defaultOptions cradle ["Baz.hs"] res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`)