diff --git a/Language/Haskell/GhcMod/Outputable.hs b/Language/Haskell/GhcMod/Outputable.hs new file mode 100644 index 000000000..8b2a6e62e --- /dev/null +++ b/Language/Haskell/GhcMod/Outputable.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +module Language.Haskell.GhcMod.Outputable where + +import Language.Haskell.GhcMod.Types + +data NoOutputConfig = NoOutputConfig + +data OutputFormat = PlainFormat + +class Outputable config a where + showOutput :: IOish m => OutputFormat -> config -> a -> m String + +instance Outputable NoOutputConfig String where + showOutput PlainFormat _ = return diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 062dbfaff..b2b0f78d2 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -153,6 +153,7 @@ Library Language.Haskell.GhcMod.Monad.State Language.Haskell.GhcMod.Monad.Types Language.Haskell.GhcMod.Output + Language.Haskell.GhcMod.Outputable Language.Haskell.GhcMod.PathsAndFiles Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.Pretty diff --git a/src/GHCMod.hs b/src/GHCMod.hs index ed28d5685..ce1213acd 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -12,6 +12,7 @@ import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Outputable import Language.Haskell.GhcMod.Find (AsyncSymbolDb, newAsyncSymbolDb, getAsyncSymbolDb) import System.FilePath (()) import System.Directory (setCurrentDirectory, getAppUserDataDirectory, @@ -81,7 +82,7 @@ legacyInteractiveLoop asyncSymbolDb world = do CmdFind symbol -> lookupSymbol symbol =<< getAsyncSymbolDb asyncSymbolDb -- other commands are handled here - x -> ghcCommands x + x -> ghcCommands PlainFormat x gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout) legacyInteractiveLoop asyncSymbolDb world' @@ -116,7 +117,7 @@ wrapGhcCommands opts cmd = forM_ (reverse $ optFileMappings opts) $ uncurry loadMMappedFiles - gmPutStr =<< ghcCommands cmd + gmPutStr =<< ghcCommands PlainFormat cmd where handleGmError action = do (e, _l) <- liftIO . evaluate =<< action @@ -132,39 +133,39 @@ wrapGhcCommands opts cmd = loadMappedFileSource from src -ghcCommands :: IOish m => GhcModCommands -> GhcModT m String --- ghcCommands cmd = action args -ghcCommands (CmdLang) = languages -ghcCommands (CmdFlag) = flags -ghcCommands (CmdDebug) = debugInfo -ghcCommands (CmdDebugComponent ts) = componentInfo ts -ghcCommands (CmdBoot) = boot --- ghcCommands (CmdNukeCaches) = nukeCaches >> return "" -ghcCommands (CmdRoot) = rootInfo -ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return "" -ghcCommands (CmdModules detail) = modules detail -ghcCommands (CmdDumpSym) = dumpSymbol >> return "" -ghcCommands (CmdFind symb) = findSymbol symb -ghcCommands (CmdDoc m) = pkgDoc m -ghcCommands (CmdLint opts file) = lint opts file -ghcCommands (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms -ghcCommands (CmdCheck files) = checkSyntax files -ghcCommands (CmdExpand files) = expandTemplate files -ghcCommands (CmdInfo file symb) = info file $ Expression symb -ghcCommands (CmdType wCon file (line, col)) = types wCon file line col -ghcCommands (CmdSplit file (line, col)) = splits file line col -ghcCommands (CmdSig file (line, col)) = sig file line col -ghcCommands (CmdAuto file (line, col)) = auto file line col -ghcCommands (CmdRefine file (line, col) expr) = refine file line col $ Expression expr +ghcCommands :: IOish m => OutputFormat -> GhcModCommands -> GhcModT m String +-- ghcCommands fmt cmd = action args +ghcCommands fmt (CmdLang) = languages >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdFlag) = flags >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdDebug) = debugInfo >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdDebugComponent ts) = componentInfo ts >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdBoot) = boot >>= showOutput fmt NoOutputConfig +-- ghcCommands fmt (CmdNukeCaches) = nukeCaches >> return "" +ghcCommands fmt (CmdRoot) = rootInfo >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdLegacyInteractive) = legacyInteractive >> return "" +ghcCommands fmt (CmdModules detail) = modules detail >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdDumpSym) = dumpSymbol >> return "" +ghcCommands fmt (CmdFind symb) = findSymbol symb >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdDoc m) = pkgDoc m >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdLint opts file) = lint opts file >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdBrowse opts ms) = (concat <$> browse opts `mapM` ms) >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdCheck files) = checkSyntax files >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdExpand files) = expandTemplate files >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdInfo file symb) = info file (Expression symb) >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdType wCon file (line, col)) = types wCon file line col >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdSplit file (line, col)) = splits file line col >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdSig file (line, col)) = sig file line col >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdAuto file (line, col)) = auto file line col >>= showOutput fmt NoOutputConfig +ghcCommands fmt (CmdRefine file (line, col) expr) = refine file line col (Expression expr) >>= showOutput fmt NoOutputConfig -- interactive-only commands -ghcCommands (CmdMapFile f) = +ghcCommands _ (CmdMapFile f) = liftIO getFileSourceFromStdin >>= loadMappedFileSource f >> return "" -ghcCommands (CmdUnmapFile f) = unloadMappedFile f >> return "" -ghcCommands (CmdQuit) = liftIO exitSuccess -ghcCommands (CmdTest file) = test file -ghcCommands cmd = throw $ InvalidCommandLine $ Left $ show cmd +ghcCommands _ (CmdUnmapFile f) = unloadMappedFile f >> return "" +ghcCommands _ (CmdQuit) = liftIO exitSuccess +ghcCommands fmt (CmdTest file) = test file >>= showOutput fmt NoOutputConfig +ghcCommands _ cmd = throw $ InvalidCommandLine $ Left $ show cmd newtype InvalidCommandLine = InvalidCommandLine (Either String String) deriving (Show, Typeable)