Rewrite `ghc-mod` command line frontend.

Language/Haskell/GhcMod/CabalApi.hs

@@ -31,7 +31,7 @@ import qualified Distribution.PackageDescription as P
 import Distribution.PackageDescription.Configuration (finalizePackageDescription)
 import Distribution.PackageDescription.Parse (readPackageDescription)
 import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))
-import Distribution.Simple.Program (ghcProgram)
+import Distribution.Simple.Program as C (ghcProgram)
 import Distribution.Simple.Program.Types (programName, programFindVersion)
 import Distribution.System (buildPlatform)
 import Distribution.Text (display)
@@ -155,7 +155,7 @@ getGHCId = CompilerId GHC <$> getGHC
 
 getGHC :: IO Version
 getGHC = do
-    mv <- programFindVersion ghcProgram silent (programName ghcProgram)
+    mv <- programFindVersion C.ghcProgram silent (programName C.ghcProgram)
     case mv of
       -- TODO: MonadError it up
         Nothing -> E.throwIO $ userError "ghc not found"

Language/Haskell/GhcMod/Error.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
 module Language.Haskell.GhcMod.Error (
     GhcModError(..)
+  , gmeDoc
   , modifyError
   , modifyError'
   , tryFix
@@ -10,6 +11,7 @@ module Language.Haskell.GhcMod.Error (
 
 import Control.Monad.Error (MonadError(..), Error(..))
 import Exception
+import Text.PrettyPrint
 
 data GhcModError = GMENoMsg
                  -- ^ Unknown error
@@ -29,6 +31,20 @@ instance Error GhcModError where
     noMsg = GMENoMsg
     strMsg = GMEString
 
+gmeDoc :: GhcModError -> Doc
+gmeDoc e = case e of
+    GMENoMsg ->
+        text "Unknown error"
+    GMEString msg ->
+        text msg
+    GMECabalConfigure msg ->
+        text "cabal configure failed: " <> gmeDoc msg
+    GMECabalFlags msg ->
+        text "retrieval of the cabal configuration flags failed: " <> gmeDoc msg
+    GMEProcess cmd msg ->
+        text ("launching operating system process `"++unwords cmd++"` failed: ")
+          <> gmeDoc msg
+
 modifyError :: MonadError e m => (e -> e) -> m a -> m a
 modifyError f action = action `catchError` \e -> throwError $ f e
 

Language/Haskell/GhcMod/Find.hs

@@ -31,9 +31,8 @@ import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.Types
 import Name (getOccString)
 import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime)
-import System.FilePath ((</>), takeDirectory)
+import System.FilePath ((</>))
 import System.IO
-import System.Environment
 
 #ifndef MIN_VERSION_containers
 #define MIN_VERSION_containers(x,y,z) 1
@@ -93,26 +92,6 @@ lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db
 loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb
 loadSymbolDb = SymbolDb <$> readSymbolDb
 
--- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
--- this is a guess but >=7.6 uses 'getExecutablePath'.
-ghcModExecutable :: IO FilePath
-#ifndef SPEC
-ghcModExecutable = do
-    dir <- getExecutablePath'
-    return $ dir </> "ghc-mod"
-#else
-ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when
-                                              -- compiling spec
-                      return "dist/build/ghc-mod/ghc-mod"
-#endif
- where
-    getExecutablePath' :: IO FilePath
-# if __GLASGOW_HASKELL__ >= 706
-    getExecutablePath' = takeDirectory <$> getExecutablePath
-# else
-    getExecutablePath' = return ""
-# endif
-
 readSymbolDb :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString])
 readSymbolDb = do
     ghcMod <- liftIO ghcModExecutable

Language/Haskell/GhcMod/Internal.hs

@@ -16,8 +16,9 @@ module Language.Haskell.GhcMod.Internal (
   , cabalDependPackages
   , cabalSourceDirs
   , cabalAllTargets
-  -- * GHC.Paths
+  -- * Various Paths
   , ghcLibDir
+  , ghcModExecutable
   -- * IO
   , getDynamicFlags
   -- * Targets
@@ -42,6 +43,8 @@ module Language.Haskell.GhcMod.Internal (
   , getCompilerMode
   , setCompilerMode
   , withOptions
+  -- * 'GhcModError'
+  , gmeDoc
   -- * 'GhcMonad' Choice
   , (||>)
   , goNext
@@ -52,11 +55,13 @@ import GHC.Paths (libdir)
 
 import Language.Haskell.GhcMod.CabalApi
 import Language.Haskell.GhcMod.DynFlags
+import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.GHCChoice
 import Language.Haskell.GhcMod.Logger
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Target
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils
 
 -- | Obtaining the directory for ghc system libraries.
 ghcLibDir :: FilePath

Language/Haskell/GhcMod/Types.hs

@@ -25,7 +25,12 @@ newtype LineSeparator = LineSeparator String
 
 data Options = Options {
     outputStyle   :: OutputStyle
-  , hlintOpts     :: [String]
+  -- | Line separator string.
+  , lineSeparator :: LineSeparator
+  -- | @ghc@ program name.
+  , ghcProgram    :: FilePath
+  -- | @cabal@ program name.
+  , cabalProgram  :: FilePath
     -- | GHC command line options set on the @ghc-mod@ command line
   , ghcUserOptions:: [GHCOption]
   -- | If 'True', 'browse' also returns operators.
@@ -34,15 +39,17 @@ data Options = Options {
   , detailed      :: Bool
   -- | If 'True', 'browse' will return fully qualified name
   , qualified     :: Bool
-  -- | Line separator string.
+  , hlintOpts     :: [String]
-  , lineSeparator :: LineSeparator
   }
 
+
 -- | A default 'Options'.
 defaultOptions :: Options
 defaultOptions = Options {
     outputStyle   = PlainStyle
   , hlintOpts     = []
+  , ghcProgram    = "ghc"
+  , cabalProgram  = "cabal"
   , ghcUserOptions= []
   , operators     = False
   , detailed      = False

Language/Haskell/GhcMod/Utils.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module Language.Haskell.GhcMod.Utils where
 
 
@@ -6,6 +7,9 @@ import MonadUtils (MonadIO, liftIO)
 import System.Directory (getCurrentDirectory, setCurrentDirectory)
 import System.Exit (ExitCode(..))
 import System.Process (readProcessWithExitCode)
+#ifndef SPEC
+import System.Environment
+#endif
 
 -- dropWhileEnd is not provided prior to base 4.5.0.0.
 dropWhileEnd :: (a -> Bool) -> [a] -> [a]
@@ -42,3 +46,20 @@ withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
 withDirectory_ dir action =
     gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
                 (\_ -> liftIO (setCurrentDirectory dir) >> action)
+
+-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
+-- this is a guess but >=7.6 uses 'getExecutablePath'.
+ghcModExecutable :: IO FilePath
+#ifndef SPEC
+ghcModExecutable = getExecutable'
+ where
+    getExecutable' :: IO FilePath
+# if __GLASGOW_HASKELL__ >= 706
+    getExecutable' = getExecutablePath
+# else
+    getExecutable' = getProgName
+# endif
+
+#else
+ghcModExecutable = return "dist/build/ghc-mod/ghc-mod"
+#endif

ghc-mod.cabal

@@ -106,6 +106,7 @@ Library
                       , io-choice
                       , monad-journal >= 0.4
                       , old-time
+                      , pretty
                       , process
                       , syb
                       , time
@@ -134,8 +135,11 @@ Executable ghc-mod
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
   Build-Depends:        base >= 4.0 && < 5
+                      , data-default
                       , directory
                       , filepath
+                      , pretty
+                      , process
                       , mtl >= 2.0
                       , ghc
                       , ghc-mod
@@ -199,6 +203,7 @@ Test-Suite spec
                       , io-choice
                       , monad-journal >= 0.4
                       , old-time
+                      , pretty
                       , process
                       , syb
                       , time

src/GHCMod.hs

@@ -3,187 +3,451 @@
 module Main where
 
 import Config (cProjectVersion)
-import Control.Applicative ((<$>))
+import Control.Arrow
-import Control.Exception (Exception, Handler(..), ErrorCall(..))
+import Control.Applicative
-import CoreMonad (liftIO)
+import Control.Exception (Exception, Handler(..), catches, throw)
-import qualified Control.Exception as E
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
+import Data.Default
+import Data.List
+import Data.Char (isSpace)
 import Language.Haskell.GhcMod
+import Language.Haskell.GhcMod.Internal
 import Paths_ghc_mod
 import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
 import qualified System.Console.GetOpt as O
-import System.Directory (doesFileExist)
 import System.Environment (getArgs)
 import System.Exit (exitFailure)
-import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)
+import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8)
+--import System.Process (rawSystem)
+--import System.Exit (exitWith)
+import Text.PrettyPrint
 
 ----------------------------------------------------------------
 
 progVersion :: String
-progVersion = "ghc-mod version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
+progVersion =
+    "ghc-mod version " ++ showVersion version ++ " compiled by GHC "
+                       ++ cProjectVersion ++ "\n"
 
-ghcOptHelp :: String
+optionUsage :: (String -> String) -> [OptDescr a] -> [String]
-ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "
+optionUsage indent opts = concatMap optUsage opts
+ where
+   optUsage (Option so lo dsc udsc) =
+       [ concat $ intersperse ", " $ addLabel `map` allFlags
+       , indent $ udsc
+       , ""
+       ]
+    where
+      allFlags = shortFlags ++ longFlags
+      shortFlags = (('-':) . return) `map` so :: [String]
+      longFlags  = ("--"++) `map` lo
 
+      addLabel f@('-':'-':_) = f ++ flagLabel "="
+      addLabel f@('-':_)     = f ++ flagLabel " "
+      addLabel _ = undefined
+
+      flagLabel s =
+          case dsc of
+            NoArg  _ -> ""
+            ReqArg _ label -> s ++ label
+            OptArg _ label -> s ++ "["++label++"]"
+
+-- TODO: Generate the stuff below automatically
 usage :: String
-usage =    progVersion
+usage =
-        ++ "Usage:\n"
+ "Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\
-        ++ "\t ghc-mod list   " ++ ghcOptHelp ++ "[-l] [-d]\n"
+ \*Global Options (OPTIONS)*\n\
-        ++ "\t ghc-mod lang    [-l]\n"
+ \    Global options can be specified before and after the command and\n\
-        ++ "\t ghc-mod flag    [-l]\n"
+ \    interspersed with command specific options\n\
-        ++ "\t ghc-mod browse " ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [<package>:]<module> [[<package>:]<module> ...]\n"
+ \\n"
-        ++ "\t ghc-mod check  " ++ ghcOptHelp ++ "<HaskellFiles...>\n"
+   ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
-        ++ "\t ghc-mod expand " ++ ghcOptHelp ++ "<HaskellFiles...>\n"
+ "*Commands*\n\
-        ++ "\t ghc-mod debug  " ++ ghcOptHelp ++ "\n"
+ \    - version\n\
-        ++ "\t ghc-mod info   " ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
+ \        Print the version of the program.\n\
-        ++ "\t ghc-mod type   " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
+ \\n\
-        ++ "\t ghc-mod split  " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
+ \    - help | --help\n\
-        ++ "\t ghc-mod sig    " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
+ \       Print this help message.\n\
-        ++ "\t ghc-mod refine " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no> <expression>\n"
+ \\n\
-        ++ "\t ghc-mod auto   " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
+ \    - list [FLAGS...]\n\
-        ++ "\t ghc-mod find    <symbol>\n"
+ \        List all visible modules.\n\
-        ++ "\t ghc-mod lint    [-h opt] <HaskellFile>\n"
+ \      Flags:\n\
-        ++ "\t ghc-mod root\n"
+ \        -d\n\
-        ++ "\t ghc-mod doc     <module>\n"
+ \            Also print the modules' package.\n\
-        ++ "\t ghc-mod boot\n"
+ \\n\
-        ++ "\t ghc-mod version\n"
+ \    - lang\n\
-        ++ "\t ghc-mod help\n"
+ \        List all known GHC language extensions.\n\
-        ++ "\n"
+ \\n\
-        ++ "<module> for \"info\" and \"type\" is not used, anything is OK.\n"
+ \    - flag\n\
-        ++ "It is necessary to maintain backward compatibility.\n"
+ \        List GHC -f<bla> flags.\n\
+ \\n\
+ \    - browse [FLAGS...] [PACKAGE:]MODULE...\n\
+ \        List symbols in a module.\n\
+ \      Flags:\n\
+ \        -o\n\
+ \            Also print operators.\n\
+ \        -d\n\
+ \            Print symbols with accompanying signatures.\n\
+ \        -q\n\
+ \            Qualify symbols.\n\
+ \\n\
+ \    - check FILE...\n\
+ \        Load the given files using GHC and report errors/warnings, but\n\
+ \        don't produce output files.\n\
+ \\n\
+ \    - expand FILE...\n\
+ \        Like `check' but also pass `-ddump-splices' to GHC.\n\
+ \\n\
+ \    - info   FILE [MODULE] EXPR\n\
+ \        Look up an identifier in the context of FILE (like ghci's `:info')\n\
+ \        MODULE is completely ignored and only allowed for backwards\n\
+ \        compatibility.\n\
+ \\n\
+ \    - type FILE [MODULE] LINE COL\n\
+ \        Get the type of the expression under (LINE,COL).\n\
+ \\n\
+ \    - split FILE [MODULE] LINE COL\n\
+ \        Split a function case by examining a type's constructors.\n\
+ \\n\
+ \        For example given the following code snippet:\n\
+ \\n\
+ \            f :: [a] -> a\n\
+ \            f x = _body\n\
+ \\n\
+ \        would be replaced by:\n\
+ \\n\
+ \            f :: [a] -> a\n\
+ \            f [] = _body\n\
+ \            f (x:xs) = _body\n\
+ \\n\
+ \        (See https://github.com/kazu-yamamoto/ghc-mod/pull/274)\n\
+ \\n\
+ \    - sig FILE MODULE LINE COL\n\
+ \        Generate initial code given a signature.\n\
+ \\n\
+ \        For example when (LINE,COL) is on the signature in the following\n\
+ \        code snippet:\n\
+ \\n\
+ \            func :: [a] -> Maybe b -> (a -> b) -> (a,b)\n\
+ \\n\
+ \        ghc-mod would add the following on the next line:\n\
+ \\n\
+ \            func x y z f = _func_body\n\
+ \\n\
+ \        (See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)\n\
+ \\n\
+ \    - refine FILE MODULE LINE COL EXPR\n\
+ \        Refine the typed hole at (LINE,COL) given EXPR.\n\
+ \\n\
+ \        For example if EXPR is `filter', which has type `(a -> Bool) -> [a]\n\
+ \          -> [a]' and (LINE,COL) is on the hole `_body' in the following\n\
+ \        code snippet:\n\
+ \\n\
+ \            filterNothing :: [Maybe a] -> [a]\n\
+ \            filterNothing xs = _body\n\
+ \\n\
+ \        ghc-mod changes the code to get a value of type `[a]', which\n\
+ \        results in:\n\
+ \\n\
+ \            filterNothing xs = filter _body_1 _body_2\n\
+ \\n\
+ \        (See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)\n\
+ \\n\
+ \    - auto FILE MODULE LINE COL\n\
+ \        Try to automatically fill the contents of a hole.\n\
+ \\n\
+ \    - find SYMBOL\n\
+ \        List all modules that define SYMBOL.\n\
+ \\n\
+ \    - lint FILE\n\
+ \        Check files using `hlint'.\n\
+ \      Flags:\n\
+ \        -l\n\
+ \            Option to be passed to hlint.\n\
+ \\n\
+ \    - root FILE\n\
+ \       Try to find the project directory given FILE. For Cabal\n\
+ \       projects this is the directory containing the cabal file, for\n\
+ \       projects that use a cabal sandbox but have no cabal file this is the\n\
+ \       directory containing the sandbox and otherwise this is the directory\n\
+ \       containing FILE.\n\
+ \\n\
+ \    - doc MODULE\n\
+ \        Try finding the html documentation directory for the given MODULE.\n\
+ \\n\
+ \    - debug\n\
+ \        Print debugging information. Please include the output in any bug\n\
+ \        reports you submit.\n\
+ \\n\
+ \    - boot\n\
+ \         Internal command used by the emacs frontend.\n"
+ -- "\n\
+ -- \The following forms are supported so ghc-mod can be invoked by\n\
+ -- \`cabal repl':\n\
+ -- \\n\
+ -- \     ghc-mod --make GHC_OPTIONS\n\
+ -- \         Pass all options through to the GHC executable.\n\
+ -- \\n\
+ -- \     ghc-mod --interactive GHC_OPTIONS [--ghc-mod]\n\
+ -- \         Start ghci emulation mode. GHC_OPTIONS are passed to the\n\
+ -- \         GHC API. If `--ghc-mod' is given ghc-mod specific extensions\n\
+ -- \         are enabled.\n"
+ where
+   indent = ("    "++)
 
+cmdUsage :: String -> String -> String
+cmdUsage cmd s =
+  let
+      -- Find command head
+      a = dropWhile (not . (("    - " ++ cmd) `isInfixOf`)) $ lines s
+      -- Take til the end of the current command block
+      b = flip takeWhile a $ \l ->
+           all isSpace l || (isIndented l && (isCurrCmdHead l || isNotCmdHead l))
+      -- Drop extra newline from the end
+      c = dropWhileEnd (all isSpace) b
+
+      isIndented    = ("    " `isPrefixOf`)
+      isNotCmdHead  = ( not .  ("    - " `isPrefixOf`))
+      isCurrCmdHead = (("    - " ++ cmd) `isPrefixOf`)
+
+      unindent (' ':' ':' ':' ':l) = l
+      unindent l = l
+  in unlines $ unindent <$> c
 ----------------------------------------------------------------
 
-argspec :: [OptDescr (Options -> Options)]
+option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a
-argspec =
+option s l udsc dsc = Option s l dsc udsc
-    let option s l udsc dsc = Option s l dsc udsc
-        reqArg udsc dsc = ReqArg dsc udsc
-    in
-      [ option "l" ["tolisp"] "print as a list of Lisp" $
-               NoArg $ \o -> o { outputStyle = LispStyle }
 
-      , option "h" ["hlintOpt"] "hlint options" $
+reqArg :: String -> (String -> a) -> ArgDescr a
-               reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o }
+reqArg udsc dsc = ReqArg dsc udsc
 
-      , option "g" ["ghcOpt"] "GHC options" $
+globalArgSpec :: [OptDescr (Options -> Options)]
-               reqArg "ghcOpt" $ \g o ->
+globalArgSpec =
-                   o { ghcUserOptions = g : ghcUserOptions o }
+      [ option "v" ["verbose"] "Be more verbose." $
-
-      , option "v" ["verbose"] "verbose" $
                NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o }
 
-      , option "o" ["operators"] "print operators, too" $
+      , option "l" ["tolisp"] "Format output as an S-Expression" $
-               NoArg $ \o -> o { operators = True }
+               NoArg $ \o -> o { outputStyle = LispStyle }
 
-      , option "d" ["detailed"] "print detailed info" $
+      , option "b" ["boundary"] "Output line separator"$
-               NoArg $ \o -> o { detailed = True }
+               reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s }
 
-      , option "q" ["qualified"] "show qualified names" $
+      , option "g" ["ghcOpt"] "Option to be passed to GHC" $
-               NoArg $ \o -> o { qualified = True }
+               reqArg "OPT" $ \g o ->
+                   o { ghcUserOptions = g : ghcUserOptions o }
 
-      , option "b" ["boundary"] "specify line separator (default is Nul string)"$
+      , option "" ["with-ghc"] "GHC executable to use" $
-               reqArg "sep" $ \s o -> o { lineSeparator = LineSeparator s }
+               reqArg "PROG" $ \p o -> o { ghcProgram = p }
+
+      , option "" ["with-cabal"] "cabal-install executable to use" $
+               reqArg "PROG" $ \p o -> o { cabalProgram = p }
   ]
 
-parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
+parseGlobalArgs ::[String] -> (Options, [String])
-parseArgs spec argv
+parseGlobalArgs argv
-    = case O.getOpt Permute spec argv of
+    = case O.getOpt RequireOrder globalArgSpec argv of
-        (o,n,[]  ) -> (foldr id defaultOptions o, n)
+        (o,r,[]  ) -> (foldr id defaultOptions o, r)
-        (_,_,errs) -> E.throw (CmdArg errs)
+        (_,_,errs) ->
+            fatalError $ "Parsing command line options failed: \n" ++ concat errs
+
+parseCommandArgs :: [OptDescr (Options -> Options)]
+                 -> [String]
+                 -> Options
+                 -> (Options, [String])
+parseCommandArgs spec argv opts
+    = case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of
+        (o,r,[])   -> (foldr id opts o, r)
+        (_,_,errs) ->
+            fatalError $ "Parsing command options failed: \n" ++ concat errs
 
 ----------------------------------------------------------------
 
-data GHCModError = SafeList
+data CmdError = UnknownCommand String
-                 | ArgumentsMismatch String
+              | NoSuchFileError String
-                 | NoSuchCommand String
+              | LibraryError GhcModError
-                 | CmdArg [String]
-                 | FileNotExist String deriving (Show, Typeable)
 
-instance Exception GHCModError
+                deriving (Show, Typeable)
+
+instance Exception CmdError
 
 ----------------------------------------------------------------
 
+data InteractiveOptions = InteractiveOptions {
+      ghcModExtensions :: Bool
+    }
+
+instance Default InteractiveOptions where
+    def = InteractiveOptions False
+
+handler :: IO a -> IO a
+handler = flip catches $
+          [ Handler $ \(FatalError msg) -> exitError msg
+          , Handler $ \(InvalidCommandLine e) -> do
+                case e of
+                  Left cmd ->
+                      exitError $ (cmdUsage cmd usage)
+                               ++ "\nghc-mod: Invalid command line form."
+                  Right msg -> exitError msg
+          ]
+
 main :: IO ()
-main = flip E.catches handlers $ do
+main = handler $ do
     hSetEncoding stdout utf8
     args <- getArgs
-    let (opt,cmdArg) = parseArgs argspec args
-    let cmdArg0 = cmdArg !. 0
-        cmdArg1 = cmdArg !. 1
-        cmdArg3 = cmdArg !. 3
-        cmdArg4 = cmdArg !. 4
-        cmdArg5 = cmdArg !. 5
-        remainingArgs = tail cmdArg
-        nArgs :: Int -> a -> a
-        nArgs n f = if length remainingArgs == n
-                        then f
-                        else E.throw (ArgumentsMismatch cmdArg0)
-    (res, _) <- runGhcModT opt $ case cmdArg0 of
-      "list"    -> modules
-      "lang"    -> languages
-      "flag"    -> flags
-      "browse"  -> concat <$> mapM browse remainingArgs
-      "check"   -> checkSyntax remainingArgs
-      "expand"  -> expandTemplate remainingArgs
-      "debug"   -> debugInfo
-      "info"    -> nArgs 3 info cmdArg1 cmdArg3
-      "type"    -> nArgs 4 $ types cmdArg1 (read cmdArg3) (read cmdArg4)
-      "split"   -> nArgs 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4)
-      "sig"     -> nArgs 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4)
-      "refine"  -> nArgs 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5
-      "auto"    -> nArgs 4 $ auto cmdArg1 (read cmdArg3) (read cmdArg4)
-      "find"    -> nArgs 1 $ findSymbol cmdArg1
-      "lint"    -> nArgs 1 $ withFile lint cmdArg1
-      "root"    -> rootInfo
-      "doc"     -> nArgs 1 $ pkgDoc cmdArg1
-      "dumpsym" -> dumpSymbol
-      "boot"    -> boot
-      "version" -> return progVersion
-      "help"    -> return $ O.usageInfo usage argspec
-      cmd       -> E.throw (NoSuchCommand cmd)
 
-    case res of
+    let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args
-      Right s -> putStr s
+        _realGhcArgs = filter (/="--ghc-mod") ghcArgs
-      Left (GMENoMsg) ->
-          hPutStrLn stderr "Unknown error"
-      Left (GMEString msg) ->
-          hPutStrLn stderr msg
-      Left (GMECabalConfigure msg) ->
-          hPutStrLn stderr $ "cabal configure failed: " ++ show msg
-      Left (GMECabalFlags msg) ->
-          hPutStrLn stderr $ "retrieval of the cabal configuration flags failed: " ++ show msg
-      Left (GMEProcess cmd msg) ->
-          hPutStrLn stderr $
-            "launching operating system process `"++c++"` failed: " ++ show msg
-          where c = unwords cmd
 
-  where
+        (globalOptions,_cmdArgs) = parseGlobalArgs modArgs
-    handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
+
-    handleThenExit handler e = handler e >> exitFailure
+        stripSeperator ("--":rest) = rest
-    handler1 :: ErrorCall -> IO ()
+        stripSeperator l = l
-    handler1 = print -- for debug
+
-    handler2 :: GHCModError -> IO ()
+    case args of
-    handler2 SafeList = printUsage
+      _
-    handler2 (ArgumentsMismatch cmd) = do
+          -- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do
-        hPutStrLn stderr $ "\"" ++ cmd ++ "\": Arguments did not match"
+          --     rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith
-        printUsage
+
-    handler2 (NoSuchCommand cmd) = do
+          -- | "--interactive" `elem` ghcArgs -> do
-        hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported"
+          --     let interactiveOptions = if "--ghc-mod" `elem` ghcArgs
-        printUsage
+          --                              then def { ghcModExtensions = True }
-    handler2 (CmdArg errs) = do
+          --                              else def
-        mapM_ (hPutStr stderr) errs
+
-        printUsage
+          --     -- TODO: pass ghcArgs' to ghc API
-    handler2 (FileNotExist file) = do
+          --     putStrLn "\ninteractive\n"
-        hPutStrLn stderr $ "\"" ++ file ++ "\" not found"
+          --     --print realGhcArgs
-        printUsage
+          --     (res, _) <- runGhcModT globalOptions $ undefined
-    printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec
+          --     case res of
-    withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a
+          --       Right s -> putStr s
-    withFile cmd file = do
+          --       Left e -> exitError $ render (gmeDoc e)
-        exist <- liftIO $ doesFileExist file
+
-        if exist
+
-            then cmd file
+          | otherwise -> do
-            else E.throw (FileNotExist file)
+              (res, _) <- runGhcModT globalOptions $ commands args
-    xs !. idx
+              case res of
-      | length xs <= idx = E.throw SafeList
+                Right s -> putStr s
-      | otherwise = xs !! idx
+                Left e -> exitError $ render (gmeDoc e)
+
+              -- Obtain ghc options by letting ourselfs be executed by
+              -- @cabal repl@
+              -- TODO: need to do something about non-cabal projects
+              -- exe <- ghcModExecutable
+              -- let cabalArgs = ["repl", "-v0", "--with-ghc="++exe]
+              --              ++ (("--ghc-option="++) `map` ("--ghc-mod":"--":args))
+
+              -- print cabalArgs
+
+              -- rawSystem "cabal" cabalArgs >>= exitWith
+
+commands :: IOish m => [String] -> GhcModT m String
+commands []         = fatalError "No command given (try --help)\n"
+commands (cmd:args) = fn args
+ where
+   fn = case cmd of
+     _ | cmd == "list" || cmd == "modules" -> modulesCmd
+     _ | cmd == "help" || cmd == "--help"  -> const $ return usage
+     "version" -> const $ return progVersion
+     "lang"    -> languagesCmd
+     "flag"    -> flagsCmd
+     "browse"  -> browseCmd
+     "check"   -> checkSyntaxCmd
+     "expand"  -> expandTemplateCmd
+     "debug"   -> debugInfoCmd
+     "info"    -> infoCmd
+     "type"    -> typesCmd
+     "split"   -> splitsCmd
+     "sig"     -> sigCmd
+     "refine"  -> refineCmd
+     "auto"    -> autoCmd
+     "find"    -> findSymbolCmd
+     "lint"    -> lintCmd
+     "root"    -> rootInfoCmd
+     "doc"     -> pkgDocCmd
+     "dumpsym" -> dumpSymbolCmd
+     "boot"    -> bootCmd
+     _         -> fatalError $ "unknown command: `" ++ cmd ++ "'"
+
+newtype FatalError = FatalError String deriving (Show, Typeable)
+instance Exception FatalError
+
+newtype InvalidCommandLine = InvalidCommandLine (Either String String)
+    deriving (Show, Typeable)
+instance Exception InvalidCommandLine
+
+exitError :: String -> IO a
+exitError msg = hPutStrLn stderr msg >> exitFailure
+
+fatalError :: String -> a
+fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
+
+withParseCmd :: IOish m
+             => [OptDescr (Options -> Options)]
+             -> ([String] -> GhcModT m a)
+             -> [String]
+             -> GhcModT m a
+withParseCmd spec action args  = do
+  (opts', rest) <- parseCommandArgs spec args <$> options
+  withOptions (const opts') $ action rest
+
+modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,
+  debugInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd,
+  findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd
+  :: IOish m => [String] -> GhcModT m String
+
+modulesCmd    = withParseCmd [] $ \[] -> modules
+languagesCmd  = withParseCmd [] $ \[] -> languages
+flagsCmd      = withParseCmd [] $ \[] -> flags
+debugInfoCmd  = withParseCmd [] $ \[] -> debugInfo
+rootInfoCmd   = withParseCmd [] $ \[] -> rootInfo
+-- internal
+dumpSymbolCmd = withParseCmd [] $ \[] -> dumpSymbol
+bootCmd       = withParseCmd [] $ \[] -> boot
+
+findSymbolCmd     = withParseCmd [] $ \[sym]  -> findSymbol sym
+pkgDocCmd         = withParseCmd [] $ \[mdl]  -> pkgDoc mdl
+lintCmd           = withParseCmd s  $ \[file] -> lint file
+ where s = hlintArgSpec
+browseCmd         = withParseCmd s  $ \mdls   -> concat <$> browse `mapM` mdls
+ where s = browseArgSpec
+checkSyntaxCmd    = withParseCmd [] $ checkAction checkSyntax
+expandTemplateCmd = withParseCmd [] $ checkAction expandTemplate
+
+typesCmd      = withParseCmd [] $ locAction  "type"  types
+splitsCmd     = withParseCmd [] $ locAction  "split" splits
+sigCmd        = withParseCmd [] $ locAction  "sig"    sig
+autoCmd       = withParseCmd [] $ locAction  "auto"   auto
+refineCmd     = withParseCmd [] $ locAction' "refine" refine
+
+infoCmd       = withParseCmd [] $ action
+  where action [file,_,expr] = info file expr
+        action [file,expr]   = info file expr
+        action _ = throw $ InvalidCommandLine (Left "info")
+
+checkAction :: ([t] -> a) -> [t] -> a
+checkAction _ []         = throw $ InvalidCommandLine (Right "No files given.")
+checkAction action files = action files
+
+locAction :: String -> (String -> Int -> Int -> a) -> [String] -> a
+locAction _ action [file,_,line,col] = action file (read line) (read col)
+locAction _ action [file,  line,col] = action file (read line) (read col)
+locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd)
+
+locAction' :: String -> (String -> Int -> Int -> String -> a) -> [String] -> a
+locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) expr
+locAction' _ action [f,  line,col,expr] = action f (read line) (read col) expr
+locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
+
+hlintArgSpec :: [OptDescr (Options -> Options)]
+hlintArgSpec =
+    [ option "h" ["hlintOpt"] "Option to be passed to hlint" $
+             reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o }
+    ]
+browseArgSpec :: [OptDescr (Options -> Options)]
+browseArgSpec =
+    [ option "o" ["operators"] "Also print operators." $
+             NoArg $ \o -> o { operators = True }
+    , option "d" ["detailed"] "Print symbols with accompanying signature." $
+             NoArg $ \o -> o { detailed = True }
+    , option "q" ["qualified"] "Qualify symbols" $
+             NoArg $ \o -> o { qualified = True }
+    ]