diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 519b2ad..e633268 100644 --- a/src/GHCMod.hs +++ b/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 - dropSession + when changed 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 - "check" -> checkSyntax [arg] - "lint" -> lint defaultLintOpts arg - "find" -> do - db <- getDb symdbreq >>= checkDb symdbreq - lookupSymbol arg db + res <- flip gcatches interactiveHandlers $ do + pargs <- maybe (throw $ InvalidCommandLine $ Left $ concat (cmd':args')) return + $ parseArgsInteractive (cmd:args) + case fst pargs of + CmdCheck{} -> checkSyntax [arg] + CmdLint{} -> lint defaultLintOpts arg + CmdFind{} -> + lookupSymbol arg =<< checkDb symdbreq =<< getDb symdbreq - "info" -> info (head args) $ Expression $ concat $ tail args' - "type" -> locArgs types args - "split" -> locArgs splits args + CmdInfo{} -> info (head args) $ Expression $ concat $ tail args' - "sig" -> locArgs sig args - "auto" -> locArgs auto args - "refine" -> locArgs' refine args + CmdRefine{} -> locArgs' refine args - "boot" -> boot - "browse" -> concat <$> browse defaultBrowseOpts `mapM` args + CmdMapFile{} -> liftIO getFileSourceFromStdin + >>= loadMappedFileSource arg + >> return "" - "map-file" -> liftIO getFileSourceFromStdin - >>= loadMappedFileSource arg - >> return "" + CmdUnmapFile{} -> unloadMappedFile arg + >> return "" - "unmap-file" -> unloadMappedFile arg - >> return "" - - "quit" -> liftIO $ exitSuccess - "" -> liftIO $ exitSuccess - _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" + CmdQuit -> liftIO exitSuccess + -- other commands are handled here + 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 diff --git a/src/GHCMod/Options.hs b/src/GHCMod/Options.hs index 3ed403b..577e2de 100644 --- a/src/GHCMod/Options.hs +++ b/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 diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs index 0a436c3..cd62f70 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/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 . +{-# 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 - $ command "lang" + hsubparser commands + +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