diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs index c0abae5..7399de1 100644 --- a/Language/Haskell/GhcMod/Boot.hs +++ b/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 = [ diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index a30eb61..3539bb7 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/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 opt =<< tryModuleInfo =<< G.findModule mdlname Nothing + processExports opts =<< 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" diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs index b30ede0..42ed23d 100644 --- a/Language/Haskell/GhcMod/Lint.hs +++ b/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 - opt <- options +lint opt file = withMappedFile file $ \tempfile -> - liftIO (hlint $ tempfile : "--quiet" : optHlintOpts opt) + liftIO (hlint $ tempfile : "--quiet" : optLintHlintOpts opt) >>= mapM (replaceFileName tempfile) >>= ghandle handler . pack where diff --git a/Language/Haskell/GhcMod/Modules.hs b/Language/Haskell/GhcMod/Modules.hs index 2b78ac4..cea9ef7 100644 --- a/Language/Haskell/GhcMod/Modules.hs +++ b/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 = do - Options { optDetailed } <- options +modules :: (IOish m, Gm m) => Bool -> m String +modules detailed = do 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 diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 1f5ec41..8d7038d 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/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 = [] } diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 88188e7..ab5fe1a 100644 --- a/ghc-mod.cabal +++ b/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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index f9b7608..b03dcaf 100644 --- a/src/GHCMod.hs +++ b/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 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 - case parseGlobalArgs args of - Left e -> throw e - Right res@(globalOptions,_) -> catches (progMain res) [ - Handler $ \(e :: GhcModError) -> - runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e) - ] + parseArgs >>= \res@(globalOptions, _) -> + catches (progMain res) [ + Handler $ \(e :: GhcModError) -> + runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e) + ] -progMain :: (Options,[String]) -> IO () -progMain (globalOptions,cmdArgs) = runGmOutT globalOptions $ - case globalCommands cmdArgs of - Just s -> gmPutStr s - Nothing -> wrapGhcCommands globalOptions cmdArgs - -globalCommands :: [String] -> Maybe String -globalCommands (cmd:_) - | cmd == "help" = Just usage - | cmd == "version" = Just ghcModVersion -globalCommands _ = Nothing +progMain :: (Options, GhcModCommands) -> IO () +progMain (globalOptions, commands) = runGmOutT globalOptions $ + wrapGhcCommands globalOptions commands -- 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] - "lint" -> lintCmd [arg] + "check" -> checkSyntax [arg] "find" -> do db <- getDb symdbreq >>= checkDb symdbreq lookupSymbol arg db - "info" -> infoCmd [head args, concat $ tail args'] - "type" -> typesCmd args - "split" -> splitsCmd args + "info" -> info (head args) $ Expression $ concat $ tail args' + "type" -> locArgs types args + "split" -> locArgs splits args - "sig" -> sigCmd args - "auto" -> autoCmd args - "refine" -> refineCmd args + "sig" -> locArgs sig args + "auto" -> locArgs auto args + "refine" -> locArgs' refine args - "boot" -> bootCmd [] - "browse" -> browseCmd args + "boot" -> boot "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 _opts [] = fatalError "No command given (try --help)" -wrapGhcCommands _opts ("root":_) = gmPutStr =<< rootInfo -wrapGhcCommands opts args = do +wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m () +wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo +wrapGhcCommands opts cmd = 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 [] = fatalError "No command given (try --help)" -ghcCommands (cmd:args) = gmPutStr =<< action args - where - action = case cmd of - _ | cmd == "list" || cmd == "modules" -> modulesCmd - "lang" -> languagesCmd - "flag" -> flagsCmd - "browse" -> browseCmd - "check" -> checkSyntaxCmd - "expand" -> expandTemplateCmd - "debug" -> debugInfoCmd - "debug-component" -> componentInfoCmd - "info" -> infoCmd - "type" -> typesCmd - "split" -> splitsCmd - "sig" -> sigCmd - "refine" -> refineCmd - "auto" -> autoCmd - "find" -> findSymbolCmd - "lint" -> lintCmd --- "root" -> rootInfoCmd - "doc" -> pkgDocCmd - "dumpsym" -> dumpSymbolCmd - "boot" -> bootCmd - "legacy-interactive" -> legacyInteractiveCmd --- "nuke-caches" -> nukeCachesCmd - _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" +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) = undefined -- handled in wrapGhcCommands +ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return "" +ghcCommands (CmdModules detail) = modules detail +ghcCommands (CmdDumpSym tmpdir) = dumpSymbol tmpdir +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 file (line, col)) = types 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 _ = fatalError "Unknown command" 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" diff --git a/src/GHCMod/Options.hs b/src/GHCMod/Options.hs new file mode 100644 index 0000000..fb43ede --- /dev/null +++ b/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) diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs new file mode 100644 index 0000000..5889104 --- /dev/null +++ b/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 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" diff --git a/src/GHCMod/Options/DocUtils.hs b/src/GHCMod/Options/DocUtils.hs new file mode 100644 index 0000000..d23e7b3 --- /dev/null +++ b/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] diff --git a/src/GHCMod/Version.hs b/src/GHCMod/Version.hs new file mode 100644 index 0000000..7c7c911 --- /dev/null +++ b/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"