Use optparse-applicative for interactive commands

src/GHCMod.hs

@@ -133,7 +133,7 @@ legacyInteractiveLoop symdbreq world = do
     liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
 
     -- blocking
-    cmdArg <- liftIO $ getLine
+    cmdArg <- liftIO getLine
 
     -- after blocking, we need to see if the world has changed.
 
@@ -143,42 +143,36 @@ legacyInteractiveLoop symdbreq world = do
                 then getCurrentWorld -- TODO: gah, we're hitting the fs twice
                 else return world
 
-    when changed $ do
+    when changed dropSession
-        dropSession
 
     let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg
         arg = concat args'
         cmd = dropWhileEnd isSpace cmd'
         args = dropWhileEnd isSpace `map` args'
 
-    res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of
+    res <- flip gcatches interactiveHandlers $ do
-        "check"  -> checkSyntax [arg]
+      pargs <- maybe (throw $ InvalidCommandLine $ Left $ concat (cmd':args')) return
-        "lint"   -> lint defaultLintOpts arg
+              $ parseArgsInteractive (cmd:args)
-        "find"   -> do
+      case fst pargs of
-            db <- getDb symdbreq >>= checkDb symdbreq
+        CmdCheck{}     -> checkSyntax [arg]
-            lookupSymbol arg db
+        CmdLint{}      -> lint defaultLintOpts arg
+        CmdFind{}      ->
+            lookupSymbol arg =<< checkDb symdbreq =<< getDb symdbreq
 
-        "info"   -> info (head args) $ Expression $ concat $ tail args'
+        CmdInfo{}      -> info (head args) $ Expression $ concat $ tail args'
-        "type"   -> locArgs types args
-        "split"  -> locArgs splits args
 
-        "sig"    -> locArgs sig args
+        CmdRefine{}    -> locArgs' refine args
-        "auto"   -> locArgs auto args
-        "refine" -> locArgs' refine args
 
-        "boot"   -> boot
+        CmdMapFile{}   ->  liftIO getFileSourceFromStdin
-        "browse" -> concat <$> browse defaultBrowseOpts `mapM` args
-
-        "map-file"   ->  liftIO getFileSourceFromStdin
                        >>= loadMappedFileSource arg
                        >>  return ""
 
-        "unmap-file" ->  unloadMappedFile arg
+        CmdUnmapFile{} -> unloadMappedFile arg
                        >> return ""
 
-        "quit"   -> liftIO $ exitSuccess
+        CmdQuit        -> liftIO exitSuccess
-        ""       -> liftIO $ exitSuccess
+        -- other commands are handled here
-        _        -> fatalError $ "unknown command: `" ++ cmd ++ "'"
+        x              -> ghcCommands x
 
     gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
     legacyInteractiveLoop symdbreq world'
@@ -189,8 +183,6 @@ legacyInteractiveLoop symdbreq world = do
           , GHandler $ \e@(ExitFailure _) -> throw e
           , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return ""
           ]
-    locArgs  a [f,l,c] = a f (read l) (read c)
-    locArgs  _ args = throw $ InvalidCommandLine $ Left $ unwords args
     locArgs' a (f:l:c:xs) = a f (read l) (read c) (Expression $ unwords xs)
     locArgs' _ args = throw $ InvalidCommandLine $ Left $ unwords args
 

src/GHCMod/Options.hs

@@ -16,6 +16,7 @@
 
 module GHCMod.Options (
   parseArgs,
+  parseArgsInteractive,
   GhcModCommands(..)
 ) where
 
@@ -35,6 +36,12 @@ parseArgs =
            $$  fullDesc
            <=> header "ghc-mod: Happy Haskell Programming"
 
+parseArgsInteractive :: [String] -> Maybe (GhcModCommands, [String])
+parseArgsInteractive args =
+  getParseResult $ execParserPure (prefs idm) opts args
+  where
+    opts = info interactiveCommandsSpec $$ fullDesc
+
 helpVersion :: Parser (a -> a)
 helpVersion =
       helper

src/GHCMod/Options/Commands.hs

@@ -13,6 +13,7 @@
 --
 -- You should have received a copy of the GNU Affero General Public License
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+{-# LANGUAGE TupleSections #-}
 
 module GHCMod.Options.Commands where
 
@@ -52,11 +53,18 @@ data GhcModCommands =
   | CmdSig FilePath Point
   | CmdAuto FilePath Point
   | CmdRefine FilePath Point Expr
+  -- interactive-only commands
+  | CmdMapFile FilePath
+  | CmdUnmapFile FilePath
+  | CmdQuit
 
 commandsSpec :: Parser GhcModCommands
 commandsSpec =
-  hsubparser
+  hsubparser commands
-    $  command "lang"
+
+commands :: Mod CommandFields GhcModCommands
+commands =
+       command "lang"
           $$  info (pure CmdLang)
           $$  progDesc "List all known GHC language extensions"
     <> command "flag"
@@ -172,6 +180,22 @@ commandsSpec =
               , text "(See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)"
               ]
 
+interactiveCommandsSpec :: Parser (GhcModCommands, [String])
+interactiveCommandsSpec =
+    (,) <$> subparser icmds <*> leftover
+    where
+      icmds =
+           commands
+        <> command "map-file"
+              $$  info mapArgSpec idm
+        <> command "unmap-file"
+              $$ info unmapArgSpec idm
+        <> command "quit"
+              $$ info (pure CmdQuit) idm
+        <> command ""
+              $$ info (pure CmdQuit) idm
+      leftover = many (strArg "...")
+
 strArg :: String -> Parser String
 strArg = argument str . metavar
 
@@ -189,7 +213,8 @@ locArgSpec x = x
 modulesArgSpec, dumpSymArgSpec, docArgSpec, findArgSpec,
   lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec,
   infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec,
-  sigArgSpec, refineArgSpec, debugComponentArgSpec :: Parser GhcModCommands
+  sigArgSpec, refineArgSpec, debugComponentArgSpec,
+  mapArgSpec, unmapArgSpec :: Parser GhcModCommands
 
 modulesArgSpec = CmdModules
   <$> switch
@@ -232,6 +257,8 @@ autoArgSpec = locArgSpec CmdAuto
 splitArgSpec = locArgSpec CmdSplit
 sigArgSpec = locArgSpec CmdSig
 refineArgSpec = locArgSpec CmdRefine <*> strArg "SYMBOL"
+mapArgSpec = filesArgsSpec (CmdMapFile . concat)
+unmapArgSpec = filesArgsSpec (CmdUnmapFile . concat)
 
 int :: ReadM Int
 int = do