add command line option: -b sep

This commit is contained in:
Shohei Murayama 2014-04-07 11:06:17 +09:00
parent a21178d2af
commit a33aeaa973

View File

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- Commands: -- Commands:
-- check <file> -- check <file>
@ -35,13 +36,18 @@ import qualified Data.Map as M
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as S import qualified Data.Set as S
import Data.Typeable
import Data.Version (showVersion)
import qualified Exception as GE import qualified Exception as GE
import GHC (Ghc, LoadHowMuch(LoadAllTargets), TargetId(TargetFile)) import GHC (Ghc, LoadHowMuch(LoadAllTargets), TargetId(TargetFile))
import qualified GHC as G import qualified GHC as G
import HscTypes (SourceError) import HscTypes (SourceError)
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal import Language.Haskell.GhcMod.Internal
import Paths_ghc_mod
import System.Console.GetOpt
import System.Directory (setCurrentDirectory) import System.Directory (setCurrentDirectory)
import System.Environment (getArgs)
import System.IO (hFlush,stdout) import System.IO (hFlush,stdout)
---------------------------------------------------------------- ----------------------------------------------------------------
@ -51,28 +57,66 @@ type Logger = IO [String]
---------------------------------------------------------------- ----------------------------------------------------------------
argspec :: [OptDescr (Options -> Options)]
argspec = [ Option "b" ["boundary"]
(ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")
"specify line separator (default is Nul string)"
]
usage :: String
usage = "ghc-modi version " ++ showVersion version ++ "\n"
++ "Usage:\n"
++ "\t ghc-modi [-b sep]\n"
++ "\t ghc-modi help\n"
parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
parseArgs spec argv
= case getOpt Permute spec argv of
(o,n,[] ) -> (foldr id defaultOptions o, n)
(_,_,errs) -> GE.throw (CmdArg errs)
----------------------------------------------------------------
data GHCModiError = CmdArg [String]
deriving (Show, Typeable)
instance GE.Exception GHCModiError
----------------------------------------------------------------
-- Running two GHC monad threads disables the handling of -- Running two GHC monad threads disables the handling of
-- C-c since installSignalHandlers is called twice, sigh. -- C-c since installSignalHandlers is called twice, sigh.
main :: IO () main :: IO ()
main = E.handle handler $ do main = handle [GE.Handler cmdHandler, GE.Handler someHandler] $
go =<< parseArgs argspec <$> getArgs
where
handle = flip GE.catches
LineSeparator lsc = lineSeparator defaultOptions
cmdHandler (CmdArg e) = do
putStr "ghc-modi:0:0:"
let x = intercalate lsc e
putStrLn x
putStr $ usageInfo usage argspec
putStrLn "NG"
someHandler (SomeException e) = do
putStr "ghc-modi:0:0:"
let x = intercalate lsc $ lines $ show e
putStrLn x
putStrLn "NG"
go (_,"help":_) = do
putStr $ usageInfo usage argspec
putStrLn "NG"
go (opt,_) = do
cradle0 <- findCradle cradle0 <- findCradle
let rootdir = cradleRootDir cradle0 let rootdir = cradleRootDir cradle0
cradle = cradle0 { cradleCurrentDir = rootdir } cradle = cradle0 { cradleCurrentDir = rootdir }
ls = lineSeparator opt
setCurrentDirectory rootdir setCurrentDirectory rootdir
mvar <- liftIO newEmptyMVar mvar <- liftIO newEmptyMVar
mlibdir <- getSystemLibDir mlibdir <- getSystemLibDir
void $ forkIO $ setupDB cradle mlibdir opt mvar void $ forkIO $ setupDB cradle mlibdir opt mvar
run cradle mlibdir opt $ loop S.empty ls mvar run cradle mlibdir opt $ loop S.empty ls mvar
where
opt = defaultOptions
ls = lineSeparator opt
LineSeparator lsc = ls
handler (SomeException e) = do
putStr "ghc-modi:0:0:"
let x = intercalate lsc $ lines $ show e
putStrLn x
putStrLn "NG"
---------------------------------------------------------------- ----------------------------------------------------------------