Optparse-applicative

Language/Haskell/GhcMod/Boot.hs

@@ -12,7 +12,7 @@ import Language.Haskell.GhcMod.Modules
 boot :: IOish m => GhcModT m String
 boot = concat <$> sequence ms
   where
-    ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules]
+    ms = [modules False, languages, flags, concat <$> mapM (browse (BrowseOpts False False False)) preBrowsedModules]
 
 preBrowsedModules :: [String]
 preBrowsedModules = [

Language/Haskell/GhcMod/Browse.hs

@@ -1,5 +1,6 @@
 module Language.Haskell.GhcMod.Browse (
-    browse
+    browse,
+    BrowseOpts(..)
   ) where
 
 import Control.Applicative
@@ -14,7 +15,6 @@ import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
 import Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Logging
 import Name (getOccString)
 import Outputable
@@ -25,13 +25,20 @@ import Prelude
 
 ----------------------------------------------------------------
 
+data BrowseOpts = BrowseOpts {
+        optBrowseOperators      :: Bool
+      , optBrowseDetailed       :: Bool
+      , optBrowseQualified      :: Bool
+    }
+
 -- | Getting functions, classes, etc from a module.
 --   If 'detailed' is 'True', their types are also obtained.
 --   If 'operators' is 'True', operators are also returned.
 browse :: forall m. IOish m
-       => String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")
+       => BrowseOpts
+       -> String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")
        -> GhcModT m String
-browse pkgmdl = do
+browse opts pkgmdl = do
     convert' . sort =<< go
   where
     -- TODO: Add API to Gm.Target to check if module is home module without
@@ -43,13 +50,11 @@ browse pkgmdl = do
         gmLog GmException "browse" $ showDoc ex
 
     goPkgModule = do
-      opt <- options
       runGmPkgGhc $
-        processExports opt =<< tryModuleInfo =<< G.findModule mdlname mpkgid
+        processExports opts =<< tryModuleInfo =<< G.findModule mdlname mpkgid
 
     goHomeModule = runGmlT [Right mdlname] $ do
-      opt <- options
+      processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing
-      processExports opt =<< tryModuleInfo =<< G.findModule mdlname Nothing
 
     tryModuleInfo m = fromJust <$> G.getModuleInfo m
 
@@ -80,31 +85,31 @@ isNotOp (h:_) = isAlpha h || (h == '_')
 isNotOp _ = error "isNotOp"
 
 processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)
-               => Options -> ModuleInfo -> m [String]
+               => BrowseOpts -> ModuleInfo -> m [String]
 processExports opt minfo = do
   let
     removeOps
-      | optOperators opt = id
+      | optBrowseOperators opt = id
       | otherwise = filter (isNotOp . getOccString)
   mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
 
 showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m)
-           => Options -> ModuleInfo -> Name -> m String
+           => BrowseOpts -> ModuleInfo -> Name -> m String
 showExport opt minfo e = do
   mtype' <- mtype
   return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
   where
-    mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optQualified opt
+    mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt
     mtype :: m (Maybe String)
     mtype
-      | optDetailed opt = do
+      | optBrowseDetailed opt = do
         tyInfo <- G.modInfoLookupName minfo e
         -- If nothing found, load dependent module and lookup global
         tyResult <- maybe (inOtherModule e) (return . Just) tyInfo
         dflag <- G.getSessionDynFlags
         return $ do
           typeName <- tyResult >>= showThing dflag
-          (" :: " ++ typeName) `justIf` optDetailed opt
+          (" :: " ++ typeName) `justIf` optBrowseDetailed opt
       | otherwise = return Nothing
     formatOp nm
       | null nm    = error "formatOp"

Language/Haskell/GhcMod/Lint.hs

@@ -5,22 +5,23 @@ import Control.Exception (SomeException(..))
 import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Types
 import Language.Haskell.HLint (hlint)
 
 import Language.Haskell.GhcMod.Utils (withMappedFile)
 
 import Data.List (stripPrefix)
 
+data LintOpts = LintOpts { optLintHlintOpts :: [String] }
+
 -- | Checking syntax of a target file using hlint.
 --   Warnings and errors are returned.
 lint :: IOish m
-     => FilePath  -- ^ A target file.
+     => LintOpts
+     -> FilePath  -- ^ A target file.
      -> GhcModT m String
-lint file = do
+lint opt file =
-  opt <- options
   withMappedFile file $ \tempfile ->
-        liftIO (hlint $ tempfile : "--quiet" : optHlintOpts opt)
+        liftIO (hlint $ tempfile : "--quiet" : optLintHlintOpts opt)
     >>= mapM (replaceFileName tempfile)
     >>= ghandle handler . pack
  where

Language/Haskell/GhcMod/Modules.hs

@@ -14,13 +14,12 @@ import qualified GHC as G
 ----------------------------------------------------------------
 
 -- | Listing installed modules.
-modules :: (IOish m, Gm m) => m String
+modules :: (IOish m, Gm m) => Bool -> m String
-modules = do
+modules detailed = do
-  Options { optDetailed } <- options
   df <- runGmPkgGhc G.getSessionDynFlags
   let mns = listVisibleModuleNames df
       pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns)
-  convert' $ nub [ if optDetailed then pkg ++ " " ++ mn else mn
+  convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn
                  | (mn, pkgs) <- pmnss, pkg <- pkgs ]
  where
    modulePkg df = lookupModulePackageInAllPackages df

Language/Haskell/GhcMod/Types.hs

@@ -102,13 +102,6 @@ data Options = Options {
   , optPrograms       :: Programs
     -- | GHC command line options set on the @ghc-mod@ command line
   , optGhcUserOptions :: [GHCOption]
-  -- | If 'True', 'browse' also returns operators.
-  , optOperators      :: Bool
-  -- | If 'True', 'browse' also returns types.
-  , optDetailed       :: Bool
-  -- | If 'True', 'browse' will return fully qualified name
-  , optQualified      :: Bool
-  , optHlintOpts      :: [String]
   , optFileMappings   :: [(FilePath, Maybe FilePath)]
   } deriving (Show)
 
@@ -128,10 +121,6 @@ defaultOptions = Options {
     , stackProgram   = "stack"
     }
   , optGhcUserOptions = []
-  , optOperators      = False
-  , optDetailed       = False
-  , optQualified      = False
-  , optHlintOpts      = []
   , optFileMappings   = []
   }
 

ghc-mod.cabal

@@ -188,6 +188,10 @@ Executable ghc-mod
   Default-Language:     Haskell2010
   Main-Is:              GHCMod.hs
   Other-Modules:        Paths_ghc_mod
+                      , GHCMod.Options
+                      , GHCMod.Options.Commands
+                      , GHCMod.Version
+                      , GHCMod.Options.DocUtils
   GHC-Options:          -Wall -fno-warn-deprecations -threaded
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
@@ -201,6 +205,8 @@ Executable ghc-mod
                       , mtl       < 2.3 && >= 2.0
                       , ghc       < 7.11
                       , fclabels  ==2.0.*
+                      , optparse-applicative ==0.11.*
+                      , ansi-wl-pprint ==0.6.*
                       , ghc-mod
 
 Executable ghc-modi

src/GHCMod.hs

@@ -2,14 +2,10 @@
 
 module Main where
 
-import Config (cProjectVersion)
 import Control.Category
 import Control.Applicative
-import Control.Arrow
 import Control.Monad
 import Data.Typeable (Typeable)
-import Data.Version (showVersion)
-import Data.Label
 import Data.List
 import Data.List.Split
 import Data.Char (isSpace)
@@ -19,261 +15,23 @@ import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Monad
-import Paths_ghc_mod
-import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
-import qualified System.Console.GetOpt as O
 import System.FilePath ((</>))
 import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
                         removeDirectoryRecursive)
-import System.Environment (getArgs)
+-- import System.Environment (getArgs)
 import System.IO
 import System.Exit
-import Text.PrettyPrint
+import Text.PrettyPrint hiding ((<>))
 import Prelude hiding ((.))
+import GHCMod.Options
 
 import Misc
 
-progVersion :: String -> String
-progVersion pf =
-    "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC "
-                               ++ cProjectVersion ++ "\n"
-
-ghcModVersion :: String
-ghcModVersion = progVersion ""
-
-ghcModiVersion :: String
-ghcModiVersion = progVersion "i"
-
-optionUsage :: (String -> String) -> [OptDescr a] -> [String]
-optionUsage indent opts = concatMap optUsage opts
- where
-   optUsage (Option so lo dsc udsc) =
-       [ intercalate ", " $ 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 =
- "Usage: ghc-mod [OPTIONS...] COMMAND [CMD_ARGS...] \n\
- \*Global Options (OPTIONS)*\n\
- \    Global options can be specified before and after the command and\n\
- \    interspersed with command specific options\n\
- \\n"
-   ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
- "*Commands*\n\
- \    - version\n\
- \        Print the version of the program.\n\
- \\n\
- \    - help\n\
- \       Print this help message.\n\
- \\n\
- \    - list [FLAGS...] | modules [FLAGS...]\n\
- \        List all visible modules.\n\
- \      Flags:\n\
- \        -d\n\
- \            Print package modules belong to.\n\
- \\n\
- \    - lang\n\
- \        List all known GHC language extensions.\n\
- \\n\
- \    - flag\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\
- \        -h\n\
- \            Option to be passed to hlint.\n\
- \\n\
- \    - root\n\
- \        Try to find the project directory. For Cabal projects this is the\n\
- \        directory containing the cabal file, for projects that use a cabal\n\
- \        sandbox but have no cabal file this is the directory containing the\n\
- \        cabal.sandbox.config file and otherwise this is the current\n\
- \        directory.\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\
- \    - debugComponent [MODULE_OR_FILE...]\n\
- \        Debugging information related to cabal component resolution.\n\
- \\n\
- \    - boot\n\
- \         Internal command used by the emacs frontend.\n\
- \\n\
- \    - legacy-interactive\n\
- \         ghc-modi compatibility mode.\n"
- where
-   indent = ("    "++)
-
-cmdUsage :: String -> String -> String
-cmdUsage cmd realUsage =
-  let
-      -- Find command head
-      a = dropWhile (not . isCmdHead) $ lines realUsage
-      -- Take til the end of the current command block
-      b = flip takeWhile a $ \l ->
-            all isSpace l || (isIndented l && (isCmdHead l || isNotCmdHead l))
-      -- Drop extra newline from the end
-      c = dropWhileEnd (all isSpace) b
-
-      isIndented    = ("    " `isPrefixOf`)
-      isNotCmdHead  = ( not .  ("    - " `isPrefixOf`))
-
-      containsAnyCmdHead s = (("    - ") `isInfixOf` s)
-      containsCurrCmdHead s = (("    - " ++ cmd) `isInfixOf` s)
-      isCmdHead s =
-          containsAnyCmdHead s &&
-            or [ containsCurrCmdHead s
-               , any (cmd `isPrefixOf`) (splitOn " | " s)
-               ]
-
-      unindent (' ':' ':' ':' ':l) = l
-      unindent l = l
-  in unlines $ unindent <$> c
-
 ghcModStyle :: Style
 ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
 
 ----------------------------------------------------------------
 
-option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a
-option s l udsc dsc = Option s l dsc udsc
-
-reqArg :: String -> (String -> a) -> ArgDescr a
-reqArg udsc dsc = ReqArg dsc udsc
-
-optArg :: String -> (Maybe String -> a) -> ArgDescr a
-optArg udsc dsc = OptArg dsc udsc
-
-intToLogLevel :: Int -> GmLogLevel
-intToLogLevel = toEnum
-
-globalArgSpec :: [OptDescr (Options -> Either [String] Options)]
-globalArgSpec =
-      [ option "v" ["verbose"] "Increase or set log level. (0-7)" $
-          optArg "LEVEL" $ \ml o -> Right $ case ml of
-              Nothing ->
-                  modify (lOoptLogLevel . lOptOutput) increaseLogLevel o
-              Just l ->
-                  set (lOoptLogLevel . lOptOutput) (toEnum $ min 7 $ read l) o
-
-      , option "s" [] "Be silent, set log level to 0" $
-          NoArg $ \o -> Right $ set (lOoptLogLevel . lOptOutput) (toEnum 0) o
-
-      , option "l" ["tolisp"] "Format output as an S-Expression" $
-          NoArg $ \o -> Right $ set (lOoptStyle . lOptOutput) LispStyle o
-
-      , option "b" ["boundary", "line-seperator"] "Output line separator"$
-          reqArg "SEP" $ \s o -> Right $ set (lOoptLineSeparator . lOptOutput) (LineSeparator s) o
-
-      , option "" ["line-prefix"] "Output line separator"$
-          reqArg "OUT,ERR" $ \s o -> let
-                [out, err] = splitOn "," s
-              in Right $ set (lOoptLinePrefix . lOptOutput) (Just (out, err)) o
-
-      , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $
-          reqArg "OPT" $ \g o -> Right $
-              o { optGhcUserOptions = g : optGhcUserOptions o }
-
 {-
 File map docs:
 
@@ -308,59 +66,6 @@ Exposed functions:
     first argument, and removes any temporary files created when file was
     mapped. Works exactly the same as `unmap-file` interactive command
 -}
-      , option "" ["map-file"] "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" $
-          reqArg "OPT" $ \g o ->
-             let m = case second (drop 1) $ span (/='=') g of
-                       (s,"") -> (s, Nothing)
-                       (f,t)  -> (f, Just t)
-             in
-             Right $ o { optFileMappings = m : optFileMappings o }
-
-      , option "" ["with-ghc"] "GHC executable to use" $
-          reqArg "PATH" $ \p o -> Right $ set (lGhcProgram . lOptPrograms) p o
-
-      , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $
-          reqArg "PATH" $ \p o -> Right $ set (lGhcPkgProgram . lOptPrograms) p o
-
-      , option "" ["with-cabal"] "cabal-install executable to use" $
-          reqArg "PATH" $ \p o -> Right $ set (lCabalProgram . lOptPrograms) p o
-
-      , option "" ["with-stack"] "stack executable to use" $
-          reqArg "PATH" $ \p o -> Right $ set (lStackProgram . lOptPrograms) p o
-
-      , option "" ["version"] "print version information" $
-          NoArg $ \_ -> Left ["version"]
-
-      , option "" ["help"] "print this help message" $
-          NoArg $ \_ -> Left ["help"]
-  ]
-
-
-
-parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
-parseGlobalArgs argv
-    = case O.getOpt' RequireOrder globalArgSpec argv of
-        (o,r,u,[]) -> case foldr (=<<) (Right defaultOptions) o of
-                        Right o' -> Right (o', u ++ r)
-                        Left c -> Right (defaultOptions, c)
-        (_,_,u,e)  -> Left $ InvalidCommandLine $ Right $
-            "Parsing command line options failed: "
-               ++ concat (e ++ map errUnrec u)
- where
-   errUnrec :: String -> String
-   errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
-
-parseCommandArgs :: [OptDescr (Options -> Either [String] Options)]
-                 -> [String]
-                 -> Options
-                 -> (Options, [String])
-parseCommandArgs spec argv opts
-    = case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of
-        (o,r,[])   -> case foldr (=<<) (Right opts) o of
-                        Right o' -> (o', r)
-                        Left c -> (defaultOptions, c)
-        (_,_,errs) ->
-            fatalError $ "Parsing command options failed: " ++ concat errs
 
 ----------------------------------------------------------------
 
@@ -381,38 +86,21 @@ handler = flip gcatches $
           [ GHandler $ \(FatalError msg) -> exitError msg
           , GHandler $ \e@(ExitSuccess) -> throw e
           , GHandler $ \e@(ExitFailure _) -> throw e
-          , GHandler $ \(InvalidCommandLine e) -> do
-                case e of
-                  Left cmd ->
-                      exitError $ "Usage for `"++cmd++"' command:\n\n"
-                                  ++ (cmdUsage cmd usage) ++ "\n"
-                                  ++ "ghc-mod: Invalid command line form."
-                  Right msg -> exitError $ "ghc-mod: " ++ msg
           , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e
           ]
 
 main :: IO ()
 main = do
     hSetEncoding stdout utf8
-    args <- getArgs
+    parseArgs >>= \res@(globalOptions, _) ->
-    case parseGlobalArgs args of
+      catches (progMain res) [
-      Left e -> throw e
+              Handler $ \(e :: GhcModError) ->
-      Right res@(globalOptions,_) -> catches (progMain res) [
+                runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
-            Handler $ \(e :: GhcModError) ->
+            ]
-              runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
-          ]
 
-progMain :: (Options,[String]) -> IO ()
+progMain :: (Options, GhcModCommands) -> IO ()
-progMain (globalOptions,cmdArgs) = runGmOutT globalOptions $
+progMain (globalOptions, commands) = runGmOutT globalOptions $
-    case globalCommands cmdArgs of
+  wrapGhcCommands globalOptions commands
-      Just s -> gmPutStr s
-      Nothing -> wrapGhcCommands globalOptions cmdArgs
-
-globalCommands :: [String] -> Maybe String
-globalCommands (cmd:_)
-    | cmd == "help"    = Just usage
-    | cmd == "version" = Just ghcModVersion
-globalCommands _       = Nothing
 
 -- ghc-modi
 legacyInteractive :: IOish m => GhcModT m ()
@@ -464,22 +152,20 @@ legacyInteractiveLoop symdbreq world = do
         args = dropWhileEnd isSpace `map` args'
 
     res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of
-        "check"  -> checkSyntaxCmd [arg]
+        "check"  -> checkSyntax [arg]
-        "lint"   -> lintCmd [arg]
         "find"    -> do
             db <- getDb symdbreq >>= checkDb symdbreq
             lookupSymbol arg db
 
-        "info"   -> infoCmd [head args, concat $ tail args']
+        "info"   -> info (head args) $ Expression $ concat $ tail args'
-        "type"   -> typesCmd args
+        "type"   -> locArgs types args
-        "split"  -> splitsCmd args
+        "split"  -> locArgs splits args
 
-        "sig"    -> sigCmd args
+        "sig"    -> locArgs sig args
-        "auto"   -> autoCmd args
+        "auto"   -> locArgs auto args
-        "refine" -> refineCmd args
+        "refine" -> locArgs' refine args
 
-        "boot"   -> bootCmd []
+        "boot"   -> boot
-        "browse" -> browseCmd args
 
         "map-file"   ->  liftIO getFileSourceFromStdin
                      >>= loadMappedFileSource arg
@@ -495,12 +181,16 @@ legacyInteractiveLoop symdbreq world = do
     gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
     legacyInteractiveLoop symdbreq world'
  where
-   interactiveHandlers =
+    interactiveHandlers =
           [ GHandler $ \e@(FatalError _) -> throw e
           , GHandler $ \e@(ExitSuccess) -> throw e
           , GHandler $ \e@(ExitFailure _) -> throw e
           , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return ""
           ]
+    locArgs  a (f:l:c:_) = a f (read l) (read c)
+    locArgs  _ _ = throw $ InvalidCommandLine $ Left "Invalid command line"
+    locArgs' a (f:l:c:xs) = a f (read l) (read c) (Expression $ concat xs)
+    locArgs' _ _ = throw $ InvalidCommandLine $ Left "Invalid command line"
 
 getFileSourceFromStdin :: IO String
 getFileSourceFromStdin = do
@@ -514,15 +204,14 @@ getFileSourceFromStdin = do
         else return []
 
 -- Someone please already rewrite the cmdline parsing code *weep* :'(
-wrapGhcCommands :: (IOish m, GmOut m) => Options -> [String] -> m ()
+wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()
-wrapGhcCommands _opts []            = fatalError "No command given (try --help)"
+wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo
-wrapGhcCommands _opts ("root":_) = gmPutStr =<< rootInfo
+wrapGhcCommands opts cmd = do
-wrapGhcCommands opts args = do
     handleGmError $ runGhcModT opts $ handler $ do
       forM_ (reverse $ optFileMappings opts) $
         uncurry loadMMappedFiles
 
-      ghcCommands args
+      gmPutStr =<< ghcCommands cmd
  where
    handleGmError action = do
      (e, _l) <- liftIO . evaluate =<< action
@@ -538,34 +227,31 @@ wrapGhcCommands opts args = do
        loadMappedFileSource from src
 
 
-ghcCommands :: IOish m => [String] -> GhcModT m ()
+ghcCommands :: IOish m => GhcModCommands -> GhcModT m String
-ghcCommands []         = fatalError "No command given (try --help)"
+-- ghcCommands cmd = action args
-ghcCommands (cmd:args) = gmPutStr =<< action args
+ghcCommands (CmdLang) = languages
- where
+ghcCommands (CmdFlag) = flags
-   action = case cmd of
+ghcCommands (CmdDebug) = debugInfo
-     _ | cmd == "list" || cmd == "modules" -> modulesCmd
+ghcCommands (CmdDebugComponent ts) = componentInfo ts
-     "lang"    -> languagesCmd
+ghcCommands (CmdBoot) = boot
-     "flag"    -> flagsCmd
+-- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""
-     "browse"  -> browseCmd
+-- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands
-     "check"   -> checkSyntaxCmd
+ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""
-     "expand"  -> expandTemplateCmd
+ghcCommands (CmdModules detail) = modules detail
-     "debug"   -> debugInfoCmd
+ghcCommands (CmdDumpSym tmpdir) = dumpSymbol tmpdir
-     "debug-component" -> componentInfoCmd
+ghcCommands (CmdFind symb) = findSymbol symb
-     "info"    -> infoCmd
+ghcCommands (CmdDoc m) = pkgDoc m
-     "type"    -> typesCmd
+ghcCommands (CmdLint opts file) = lint opts file
-     "split"   -> splitsCmd
+ghcCommands (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms
-     "sig"     -> sigCmd
+ghcCommands (CmdCheck files) = checkSyntax files
-     "refine"  -> refineCmd
+ghcCommands (CmdExpand files) = expandTemplate files
-     "auto"    -> autoCmd
+ghcCommands (CmdInfo file symb) = info file $ Expression symb
-     "find"    -> findSymbolCmd
+ghcCommands (CmdType file (line, col)) = types file line col
-     "lint"    -> lintCmd
+ghcCommands (CmdSplit file (line, col)) = splits file line col
---     "root"    -> rootInfoCmd
+ghcCommands (CmdSig file (line, col)) = sig file line col
-     "doc"     -> pkgDocCmd
+ghcCommands (CmdAuto file (line, col)) = auto file line col
-     "dumpsym" -> dumpSymbolCmd
+ghcCommands (CmdRefine file (line, col) expr) = refine file line col $ Expression expr
-     "boot"    -> bootCmd
+ghcCommands _ = fatalError "Unknown command"
-     "legacy-interactive" -> legacyInteractiveCmd
---     "nuke-caches" -> nukeCachesCmd
-     _         -> fatalError $ "unknown command: `" ++ cmd ++ "'"
 
 newtype FatalError = FatalError String deriving (Show, Typeable)
 instance Exception FatalError
@@ -580,114 +266,11 @@ exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
 fatalError :: String -> a
 fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
 
-withParseCmd :: IOish m
-             => [OptDescr (Options -> Either [String] 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
-
-withParseCmd' :: (IOish m, ExceptionMonad m)
-              => String
-              -> [OptDescr (Options -> Either [String] Options)]
-              -> ([String] -> GhcModT m a)
-              -> [String]
-              -> GhcModT m a
-withParseCmd' cmd spec action args =
-    catchArgs cmd $ withParseCmd spec action args
-
 catchArgs :: (Monad m, ExceptionMonad m) => String -> m a -> m a
 catchArgs cmd action =
     action `gcatch` \(PatternMatchFail _) ->
         throw $ InvalidCommandLine (Left cmd)
 
-modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,
-  debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd,
-  refineCmd, autoCmd, findSymbolCmd, lintCmd, pkgDocCmd,
-  dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd
-  :: IOish m => [String] -> GhcModT m String
-
-modulesCmd    = withParseCmd' "modules" s $ \[] -> modules
- where s = modulesArgSpec
-languagesCmd  = withParseCmd' "lang"    [] $ \[] -> languages
-flagsCmd      = withParseCmd' "flag"    [] $ \[] -> flags
-debugInfoCmd  = withParseCmd' "debug"   [] $ \[] -> debugInfo
-componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts
--- internal
-bootCmd       = withParseCmd' "boot" [] $ \[] -> boot
-nukeCachesCmd = withParseCmd' "nuke-caches" [] $ \[] -> nukeCaches >> return ""
-
-dumpSymbolCmd     = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir
-findSymbolCmd     = withParseCmd' "find" [] $ \[sym]  -> findSymbol sym
-pkgDocCmd         = withParseCmd' "doc"  [] $ \[mdl]  -> pkgDoc mdl
-lintCmd           = withParseCmd' "lint" 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 $ Expression expr
-        action [file,expr]   = info file $ Expression expr
-        action _ = throw $ InvalidCommandLine (Left "info")
-
-legacyInteractiveCmd = withParseCmd [] go
- where
-   go [] =
-       legacyInteractive >> return ""
-   go ("help":[]) =
-       return usage
-   go ("version":[]) =
-       return ghcModiVersion
-   go _ = throw $ InvalidCommandLine (Left "legacy-interactive")
-
-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 -> Expression -> a) -> [String] -> a
-locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) (Expression expr)
-locAction' _ action [f,  line,col,expr] = action f (read line) (read col) (Expression expr)
-locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
-
-
-modulesArgSpec :: [OptDescr (Options -> Either [String] Options)]
-modulesArgSpec =
-    [ option "d" ["detailed"] "Print package modules belong to." $
-             NoArg $ \o -> Right $ o { optDetailed = True }
-    ]
-
-
-hlintArgSpec :: [OptDescr (Options -> Either [String] Options)]
-hlintArgSpec =
-    [ option "h" ["hlintOpt"] "Option to be passed to hlint" $
-             reqArg "hlintOpt" $ \h o -> Right $ o { optHlintOpts = h : optHlintOpts o }
-    ]
-
-browseArgSpec :: [OptDescr (Options -> Either [String] Options)]
-browseArgSpec =
-    [ option "o" ["operators"] "Also print operators." $
-             NoArg $ \o -> Right $ o { optOperators = True }
-    , option "d" ["detailed"] "Print symbols with accompanying signature." $
-             NoArg $ \o -> Right $ o { optDetailed = True }
-    , option "q" ["qualified"] "Qualify symbols" $
-             NoArg $ \o -> Right $ o { optQualified = True }
-    ]
-
 nukeCaches :: IOish m => GhcModT m ()
 nukeCaches = do
   chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"

src/GHCMod/Options.hs

@@ -0,0 +1,185 @@
+module GHCMod.Options (
+  parseArgs,
+  parseCommandsFromList,
+  GhcModCommands(..)
+) where
+
+import Options.Applicative
+import Options.Applicative.Types
+import Language.Haskell.GhcMod.Types
+import Control.Arrow
+import GHCMod.Options.Commands
+import GHCMod.Version
+
+parseArgs :: IO (Options, GhcModCommands)
+parseArgs =
+  execParser opts
+  where
+    opts = info (argAndCmdSpec <**> helpVersion)
+      ( fullDesc
+     <> header "ghc-mod: Happy Haskell Programming" )
+
+parseCommandsFromList :: [String] -> Either String GhcModCommands
+parseCommandsFromList args =
+  case execParserPure (prefs idm) (info commandsSpec idm) args of
+    Success a -> Right a
+    Failure h -> Left $ show h
+    CompletionInvoked _ -> error "WTF"
+
+helpVersion :: Parser (a -> a)
+helpVersion =
+  helper <*>
+  abortOption (InfoMsg ghcModVersion)
+    (long "version" <> help "Print the version of the program.") <*>
+  argument r (value id <> metavar "")
+  where
+    r :: ReadM (a -> a)
+    r = do
+      v <- readerAsk
+      case v of
+        "help" -> readerAbort ShowHelpText
+        "version" -> readerAbort $ InfoMsg ghcModVersion
+        _ -> return id
+
+argAndCmdSpec :: Parser (Options, GhcModCommands)
+argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec
+
+splitOn :: Eq a => a -> [a] -> ([a], [a])
+splitOn c = second (drop 1) . break (==c)
+
+getLogLevel :: Int -> GmLogLevel
+getLogLevel = toEnum . min 7
+
+logLevelParser :: Parser GmLogLevel
+logLevelParser =
+  getLogLevel <$>
+    (
+    silentSwitch <|> logLevelSwitch <|> logLevelOption
+    )
+  where
+    logLevelOption =
+      option int (
+        long "verbose" <>
+        short 'v' <>
+        metavar "LEVEL" <>
+        value 4 <>
+        showDefault <>
+        help "Set log level. (0-7)"
+      )
+    logLevelSwitch =
+      (4+) . length <$> many (flag' () (
+        long "verbose" <>
+        short 'v' <>
+        help "Increase log level"
+      ))
+    silentSwitch = (\v -> if v then 0 else 4) <$>
+      switch (
+        long "silent" <>
+        short 's' <>
+        help "Be silent, set log level to 0"
+      )
+
+outputOptsSpec :: Parser OutputOpts
+outputOptsSpec = OutputOpts <$>
+      logLevelParser <*>
+      flag PlainStyle LispStyle (
+        long "tolisp" <>
+        short 'l' <>
+        help "Format output as an S-Expression"
+      ) <*>
+      (LineSeparator <$> strOption (
+        long "boundary" <>
+        long "line-separator" <>
+        short 'b' <>
+        metavar "SEP" <>
+        value "\0" <>
+        showDefault <>
+        help "Output line separator"
+      )) <*>
+      optional (splitOn ',' <$> strOption (
+        long "line-prefix" <>
+        metavar "OUT,ERR" <>
+        help "Output prefixes"
+      ))
+
+programsArgSpec :: Parser Programs
+programsArgSpec = Programs <$>
+      strOption (
+        long "with-ghc" <>
+        value "ghc" <>
+        showDefault <>
+        help "GHC executable to use"
+      ) <*>
+      strOption (
+        long "with-ghc-pkg" <>
+        value "ghc-pkg" <>
+        showDefault <>
+        help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
+      ) <*>
+      strOption (
+        long "with-cabal" <>
+        value "cabal" <>
+        showDefault <>
+        help "cabal-install executable to use"
+      ) <*>
+      strOption (
+        long "with-stack" <>
+        value "stack" <>
+        showDefault <>
+        help "stack executable to use"
+      )
+
+globalArgSpec :: Parser Options
+globalArgSpec = Options <$>
+      outputOptsSpec <*> -- optOutput
+      programsArgSpec <*> -- optPrograms
+      many (strOption ( -- optGhcUserOptions
+        long "ghcOpt" <>
+        long "ghc-option" <>
+        short 'g' <>
+        metavar "OPT" <>
+        help "Option to be passed to GHC"
+      )) <*>
+      many fileMappingSpec -- optFileMappings   = []
+  where
+    {-
+    File map docs:
+
+    CLI options:
+    * `--map-file "file1.hs=file2.hs"` can be used to tell
+        ghc-mod that it should take source code for `file1.hs` from `file2.hs`.
+        `file1.hs` can be either full path, or path relative to project root.
+        `file2.hs` has to be either relative to project root,
+        or full path (preferred).
+    * `--map-file "file.hs"` can be used to tell ghc-mod that it should take
+        source code for `file.hs` from stdin. File end marker is `\EOT\n`,
+        i.e. `\x04\x0A`. `file.hs` may or may not exist, and should be
+        either full path, or relative to project root.
+
+    Interactive commands:
+    * `map-file file.hs` -- tells ghc-modi to read `file.hs` source from stdin.
+        Works the same as second form of `--map-file` CLI option.
+    * `unmap-file file.hs` -- unloads previously mapped file, so that it's
+        no longer mapped. `file.hs` can be full path or relative to
+        project root, either will work.
+
+    Exposed functions:
+    * `loadMappedFile :: FilePath -> FilePath -> GhcModT m ()` -- maps `FilePath`,
+        given as first argument to take source from `FilePath` given as second
+        argument. Works exactly the same as first form of `--map-file`
+        CLI option.
+    * `loadMappedFileSource :: FilePath -> String -> GhcModT m ()` -- maps
+        `FilePath`, given as first argument to have source as given
+        by second argument. Works exactly the same as second form of `--map-file`
+        CLI option, sans reading from stdin.
+    * `unloadMappedFile :: FilePath -> GhcModT m ()` -- unmaps `FilePath`, given as
+        first argument, and removes any temporary files created when file was
+        mapped. Works exactly the same as `unmap-file` interactive command
+    -}
+    fileMappingSpec =
+      getFileMapping . splitOn '=' <$> strOption (
+        long "map-file" <>
+        metavar "MAPPING" <>
+        help "Redirect one file to another, --map-file \"file1.hs=file2.hs\""
+      )
+    getFileMapping = second (\i -> if null i then Nothing else Just i)

src/GHCMod/Options/Commands.hs

@@ -0,0 +1,231 @@
+module GHCMod.Options.Commands where
+
+import Options.Applicative
+import Options.Applicative.Types
+import Language.Haskell.GhcMod.Lint (LintOpts(..))
+import Language.Haskell.GhcMod.Browse (BrowseOpts(..))
+import Text.Read (readMaybe)
+import GHCMod.Options.DocUtils
+
+type Symbol = String
+type Expr = String
+type Module = String
+type Line = Int
+type Col = Int
+type Point = (Line, Col)
+
+data GhcModCommands =
+    CmdLang
+  | CmdFlag
+  | CmdDebug
+  | CmdBoot
+  | CmdNukeCaches
+  | CmdRoot
+  | CmdLegacyInteractive
+  | CmdModules Bool
+  | CmdDumpSym FilePath
+  | CmdFind Symbol
+  | CmdDoc Module
+  | CmdLint LintOpts FilePath
+  | CmdBrowse BrowseOpts [Module]
+  | CmdDebugComponent [String]
+  | CmdCheck [FilePath]
+  | CmdExpand [FilePath]
+  | CmdInfo FilePath Symbol
+  | CmdType FilePath Point
+  | CmdSplit FilePath Point
+  | CmdSig FilePath Point
+  | CmdAuto FilePath Point
+  | CmdRefine FilePath Point Expr
+
+int :: ReadM Int
+int = do
+  v <- readerAsk
+  maybe (readerError $ "Not a number \"" ++ v ++ "\"") return $ readMaybe v
+
+commandsSpec :: Parser GhcModCommands
+commandsSpec =
+  hsubparser (
+       command "lang" (
+          info (pure CmdLang)
+          (progDesc "List all known GHC language extensions"))
+    <> command "flag" (
+          info (pure CmdFlag)
+          (progDesc "List GHC -f<foo> flags"))
+    <> command "debug" (
+          info (pure CmdDebug)
+          (progDesc
+            "Print debugging information. Please include the output in any bug\
+            \ reports you submit"))
+    <> command "debug-component" (
+          info debugComponentArgSpec
+          (progDesc "Debugging information related to cabal component resolution"))
+    <> command "boot" (
+          info (pure CmdBoot)
+          (progDesc "Internal command used by the emacs frontend"))
+    -- <> command "nuke-caches" (
+    --       info (pure CmdNukeCaches) idm)
+    <> command "root" (
+          info (pure CmdRoot)
+          (progDesc
+            "Try to find the project directory. For Cabal projects this is the\
+            \ directory containing the cabal file, for projects that use a cabal\
+            \ sandbox but have no cabal file this is the directory containing the\
+            \ cabal.sandbox.config file and otherwise this is the current\
+            \ directory"
+          ))
+    <> command "legacy-interactive" (
+          info (pure CmdLegacyInteractive)
+          (progDesc "ghc-modi compatibility mode"))
+    <> command "list" (
+          info modulesArgSpec
+          (progDesc "List all visible modules"))
+    <> command "modules" (
+          info modulesArgSpec
+          (progDesc "List all visible modules"))
+    <> command "dumpsym" (
+          info dumpSymArgSpec idm)
+    <> command "find" (
+          info findArgSpec
+          (progDesc "List all modules that define SYMBOL"))
+    <> command "doc" (
+          info docArgSpec
+          (progDesc "Try finding the html documentation directory for the given MODULE"))
+    <> command "lint" (
+          info lintArgSpec
+          (progDesc "Check files using `hlint'"))
+    <> command "browse" (
+          info browseArgSpec
+          (progDesc "List symbols in a module"))
+    <> command "check" (
+          info checkArgSpec
+          (progDesc "Load the given files using GHC and report errors/warnings,\
+                    \ but don't produce output files"))
+    <> command "expand" (
+          info expandArgSpec
+          (progDesc "Like `check' but also pass `-ddump-splices' to GHC"))
+    <> command "info" (
+          info infoArgSpec
+          (progDesc
+            "Look up an identifier in the context of FILE (like ghci's `:info')\
+            \ MODULE is completely ignored and only allowed for backwards\
+            \ compatibility"))
+    <> command "type" (
+          info typeArgSpec
+          (progDesc "Get the type of the expression under (LINE,COL)"))
+    <> command "split" (
+          info splitArgSpec
+          (progDesc
+            "Split a function case by examining a type's constructors"
+          <> desc [
+            text "For example given the following code snippet:"
+          , code [
+              "f :: [a] -> a"
+            , "f x = _body"
+            ]
+          , text "would be replaced by:"
+          , code [
+              "f :: [a] -> a"
+            , "f [] = _body"
+            , "f (x:xs) = _body"
+            ]
+          , text "(See https://github.com/kazu-yamamoto/ghc-mod/pull/274)"
+          ]))
+    <> command "sig" (
+          info sigArgSpec
+          (progDesc
+            "Generate initial code given a signature"
+          <> desc [
+            text "For example when (LINE,COL) is on the signature in the following\
+            \ code snippet:"
+            , code ["func :: [a] -> Maybe b -> (a -> b) -> (a,b)"]
+            , text "ghc-mod would add the following on the next line:"
+            , code ["func x y z f = _func_body"]
+            , text "(See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)"
+            ]
+          ))
+    <> command "auto" (
+          info autoArgSpec
+          (progDesc "Try to automatically fill the contents of a hole"))
+    <> command "refine" (
+          info refineArgSpec
+          (progDesc
+            "Refine the typed hole at (LINE,COL) given EXPR"
+          <> desc [
+            text "For example if EXPR is `filter', which has type `(a -> Bool) -> [a]\
+              \ -> [a]' and (LINE,COL) is on the hole `_body' in the following\
+              \ code snippet:"
+          , code [
+                "filterNothing :: [Maybe a] -> [a]"
+              , "filterNothing xs = _body"
+              ]
+          , text "ghc-mod changes the code to get a value of type `[a]', which\
+            \ results in:"
+          , code [ "filterNothing xs = filter _body_1 _body_2" ]
+          , text "(See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)"
+          ]
+          ))
+    )
+
+strArg :: String -> Parser String
+strArg = argument str . metavar
+
+filesArgsSpec :: ([String] -> b) -> Parser b
+filesArgsSpec x = x <$> some (strArg "FILES..")
+
+locArgSpec :: (String -> (Int, Int) -> b) -> Parser b
+locArgSpec x = x <$>
+  strArg "FILE" <*>
+  ( (,) <$>
+    argument int (metavar "LINE") <*>
+    argument int (metavar "COL")
+  )
+
+modulesArgSpec, dumpSymArgSpec, docArgSpec, findArgSpec,
+  lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec,
+  infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec,
+  sigArgSpec, refineArgSpec, debugComponentArgSpec :: Parser GhcModCommands
+
+modulesArgSpec = CmdModules <$>
+  switch (
+        long "detailed" <>
+        short 'd' <>
+        help "Print package modules belong to"
+      )
+dumpSymArgSpec = CmdDumpSym <$> strArg "TMPDIR"
+findArgSpec = CmdFind <$> strArg "SYMBOL"
+docArgSpec = CmdDoc <$> strArg "MODULE"
+lintArgSpec = CmdLint <$>
+  (LintOpts <$> many (strOption (
+    long "hlintOpt" <>
+    short 'h' <>
+    help "Option to be passed to hlint"
+  ))) <*> strArg "FILE"
+browseArgSpec = CmdBrowse <$>
+  (BrowseOpts <$>
+    switch (
+      long "operators" <>
+      short 'o' <>
+      help "Also print operators"
+    ) <*> -- optOperators      = False
+    switch (
+      long "detailed" <>
+      short 'd' <>
+      help "Print symbols with accompanying signature"
+    ) <*> -- optDetailed       = False
+    switch (
+      long "qualified" <>
+      short 'q' <>
+      help "Qualify symbols"
+    )) <*> some (strArg "MODULE")
+debugComponentArgSpec = filesArgsSpec CmdDebugComponent
+checkArgSpec = filesArgsSpec CmdCheck
+expandArgSpec = filesArgsSpec CmdExpand
+infoArgSpec = CmdInfo <$>
+    strArg "FILE" <*>
+    strArg "SYMBOL"
+typeArgSpec = locArgSpec CmdType
+autoArgSpec = locArgSpec CmdAuto
+splitArgSpec = locArgSpec CmdSplit
+sigArgSpec = locArgSpec CmdSig
+refineArgSpec = locArgSpec CmdRefine <*> strArg "SYMBOL"

src/GHCMod/Options/DocUtils.hs

@@ -0,0 +1,14 @@
+module GHCMod.Options.DocUtils (
+  module PP,
+  desc,
+  code
+) where
+
+import Options.Applicative
+import Text.PrettyPrint.ANSI.Leijen as PP hiding ((<>), (<$>), int)
+
+desc :: [Doc] -> InfoMod a
+desc = footerDoc . Just . indent 2 . vsep
+
+code :: [String] -> Doc
+code x = vsep [line, indent 4 $ vsep $ map text x, line]

src/GHCMod/Version.hs

@@ -0,0 +1,16 @@
+module GHCMod.Version where
+
+import Paths_ghc_mod
+import Data.Version (showVersion)
+import Config (cProjectVersion)
+
+progVersion :: String -> String
+progVersion pf =
+    "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC "
+                               ++ cProjectVersion ++ "\n"
+
+ghcModVersion :: String
+ghcModVersion = progVersion ""
+
+ghcModiVersion :: String
+ghcModiVersion = progVersion "i"