better error handling.
This commit is contained in:
parent
d23f57e1b6
commit
3ea98737b1
@ -20,12 +20,12 @@ module Main where
|
|||||||
|
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, readMVar)
|
import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, readMVar)
|
||||||
import Control.Exception (SomeException(..))
|
import Control.Exception (SomeException(..), Exception)
|
||||||
import qualified Control.Exception as E
|
import qualified Control.Exception as E
|
||||||
import Control.Monad (when, void)
|
import Control.Monad (when, void)
|
||||||
import CoreMonad (liftIO)
|
import CoreMonad (liftIO)
|
||||||
import Data.Function (on)
|
import Data.Function (on)
|
||||||
import Data.List (intercalate, groupBy, sort, find)
|
import Data.List (groupBy, sort, find)
|
||||||
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
|
||||||
@ -87,14 +87,14 @@ parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
|
|||||||
parseArgs spec argv
|
parseArgs spec argv
|
||||||
= case getOpt Permute spec argv of
|
= case getOpt Permute spec argv of
|
||||||
(o,n,[] ) -> (foldr id defaultOptions o, n)
|
(o,n,[] ) -> (foldr id defaultOptions o, n)
|
||||||
(_,_,errs) -> GE.throw (CmdArg errs)
|
(_,_,errs) -> E.throw (CmdArg errs)
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
data GHCModiError = CmdArg [String]
|
data GHCModiError = CmdArg [String]
|
||||||
deriving (Show, Typeable)
|
deriving (Show, Typeable)
|
||||||
|
|
||||||
instance GE.Exception GHCModiError
|
instance Exception GHCModiError
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
@ -102,26 +102,12 @@ instance GE.Exception GHCModiError
|
|||||||
-- C-c since installSignalHandlers is called twice, sigh.
|
-- C-c since installSignalHandlers is called twice, sigh.
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = handle [GE.Handler cmdHandler, GE.Handler someHandler] $
|
main = E.handle cmdHandler $
|
||||||
go =<< parseArgs argspec <$> getArgs
|
go =<< parseArgs argspec <$> getArgs
|
||||||
where
|
where
|
||||||
handle = flip GE.catches
|
cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec
|
||||||
LineSeparator lsc = lineSeparator defaultOptions
|
go (_,"help":_) = putStr $ usageInfo usage argspec
|
||||||
cmdHandler (CmdArg e) = do
|
go (opt,_) = E.handle someHandler $ 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 }
|
||||||
@ -130,6 +116,13 @@ main = handle [GE.Handler cmdHandler, GE.Handler someHandler] $
|
|||||||
mlibdir <- getSystemLibDir
|
mlibdir <- getSystemLibDir
|
||||||
void $ forkIO $ setupDB cradle mlibdir opt mvar
|
void $ forkIO $ setupDB cradle mlibdir opt mvar
|
||||||
run cradle mlibdir opt $ loop opt S.empty mvar
|
run cradle mlibdir opt $ loop opt S.empty mvar
|
||||||
|
where
|
||||||
|
someHandler (SomeException e) = do
|
||||||
|
-- fixme: this is not perfece for -l
|
||||||
|
-- because each command expect its own s-expression.
|
||||||
|
let ret = convert opt $ "ghc-modi:0:0:" ++ show e
|
||||||
|
putStr ret
|
||||||
|
putStrLn "NG"
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user