diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index fbdb513..fc56adb 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -31,7 +31,7 @@ import qualified Distribution.PackageDescription as P import Distribution.PackageDescription.Configuration (finalizePackageDescription) import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..)) -import Distribution.Simple.Program (ghcProgram) +import Distribution.Simple.Program as C (ghcProgram) import Distribution.Simple.Program.Types (programName, programFindVersion) import Distribution.System (buildPlatform) import Distribution.Text (display) @@ -155,7 +155,7 @@ getGHCId = CompilerId GHC <$> getGHC getGHC :: IO Version getGHC = do - mv <- programFindVersion ghcProgram silent (programName ghcProgram) + mv <- programFindVersion C.ghcProgram silent (programName C.ghcProgram) case mv of -- TODO: MonadError it up Nothing -> E.throwIO $ userError "ghc not found" diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 55a666d..2215ab9 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} module Language.Haskell.GhcMod.Error ( GhcModError(..) + , gmeDoc , modifyError , modifyError' , tryFix @@ -10,6 +11,7 @@ module Language.Haskell.GhcMod.Error ( import Control.Monad.Error (MonadError(..), Error(..)) import Exception +import Text.PrettyPrint data GhcModError = GMENoMsg -- ^ Unknown error @@ -29,6 +31,20 @@ instance Error GhcModError where noMsg = GMENoMsg strMsg = GMEString +gmeDoc :: GhcModError -> Doc +gmeDoc e = case e of + GMENoMsg -> + text "Unknown error" + GMEString msg -> + text msg + GMECabalConfigure msg -> + text "cabal configure failed: " <> gmeDoc msg + GMECabalFlags msg -> + text "retrieval of the cabal configuration flags failed: " <> gmeDoc msg + GMEProcess cmd msg -> + text ("launching operating system process `"++unwords cmd++"` failed: ") + <> gmeDoc msg + modifyError :: MonadError e m => (e -> e) -> m a -> m a modifyError f action = action `catchError` \e -> throwError $ f e diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 2a09664..8f27a63 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -31,9 +31,8 @@ import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Types import Name (getOccString) import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime) -import System.FilePath ((), takeDirectory) +import System.FilePath (()) import System.IO -import System.Environment #ifndef MIN_VERSION_containers #define MIN_VERSION_containers(x,y,z) 1 @@ -93,26 +92,6 @@ lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb loadSymbolDb = SymbolDb <$> readSymbolDb --- | Returns the path to the currently running ghc-mod executable. With ghc<7.6 --- this is a guess but >=7.6 uses 'getExecutablePath'. -ghcModExecutable :: IO FilePath -#ifndef SPEC -ghcModExecutable = do - dir <- getExecutablePath' - return $ dir "ghc-mod" -#else -ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when - -- compiling spec - return "dist/build/ghc-mod/ghc-mod" -#endif - where - getExecutablePath' :: IO FilePath -# if __GLASGOW_HASKELL__ >= 706 - getExecutablePath' = takeDirectory <$> getExecutablePath -# else - getExecutablePath' = return "" -# endif - readSymbolDb :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString]) readSymbolDb = do ghcMod <- liftIO ghcModExecutable diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index e222ad9..a6454da 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -16,8 +16,9 @@ module Language.Haskell.GhcMod.Internal ( , cabalDependPackages , cabalSourceDirs , cabalAllTargets - -- * GHC.Paths + -- * Various Paths , ghcLibDir + , ghcModExecutable -- * IO , getDynamicFlags -- * Targets @@ -42,6 +43,8 @@ module Language.Haskell.GhcMod.Internal ( , getCompilerMode , setCompilerMode , withOptions + -- * 'GhcModError' + , gmeDoc -- * 'GhcMonad' Choice , (||>) , goNext @@ -52,11 +55,13 @@ import GHC.Paths (libdir) import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.DynFlags +import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Utils -- | Obtaining the directory for ghc system libraries. ghcLibDir :: FilePath diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index ad03a0c..ba681bf 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -25,7 +25,12 @@ newtype LineSeparator = LineSeparator String data Options = Options { outputStyle :: OutputStyle - , hlintOpts :: [String] + -- | Line separator string. + , lineSeparator :: LineSeparator + -- | @ghc@ program name. + , ghcProgram :: FilePath + -- | @cabal@ program name. + , cabalProgram :: FilePath -- | GHC command line options set on the @ghc-mod@ command line , ghcUserOptions:: [GHCOption] -- | If 'True', 'browse' also returns operators. @@ -34,15 +39,17 @@ data Options = Options { , detailed :: Bool -- | If 'True', 'browse' will return fully qualified name , qualified :: Bool - -- | Line separator string. - , lineSeparator :: LineSeparator + , hlintOpts :: [String] } + -- | A default 'Options'. defaultOptions :: Options defaultOptions = Options { outputStyle = PlainStyle , hlintOpts = [] + , ghcProgram = "ghc" + , cabalProgram = "cabal" , ghcUserOptions= [] , operators = False , detailed = False diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 413d2de..a38b6c5 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.Utils where @@ -6,6 +7,9 @@ import MonadUtils (MonadIO, liftIO) import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Exit (ExitCode(..)) import System.Process (readProcessWithExitCode) +#ifndef SPEC +import System.Environment +#endif -- dropWhileEnd is not provided prior to base 4.5.0.0. dropWhileEnd :: (a -> Bool) -> [a] -> [a] @@ -42,3 +46,20 @@ withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a withDirectory_ dir action = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) (\_ -> liftIO (setCurrentDirectory dir) >> action) + +-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6 +-- this is a guess but >=7.6 uses 'getExecutablePath'. +ghcModExecutable :: IO FilePath +#ifndef SPEC +ghcModExecutable = getExecutable' + where + getExecutable' :: IO FilePath +# if __GLASGOW_HASKELL__ >= 706 + getExecutable' = getExecutablePath +# else + getExecutable' = getProgName +# endif + +#else +ghcModExecutable = return "dist/build/ghc-mod/ghc-mod" +#endif diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 77401af..e81be62 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -106,6 +106,7 @@ Library , io-choice , monad-journal >= 0.4 , old-time + , pretty , process , syb , time @@ -134,8 +135,11 @@ Executable ghc-mod Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 + , data-default , directory , filepath + , pretty + , process , mtl >= 2.0 , ghc , ghc-mod @@ -199,6 +203,7 @@ Test-Suite spec , io-choice , monad-journal >= 0.4 , old-time + , pretty , process , syb , time diff --git a/src/GHCMod.hs b/src/GHCMod.hs index e2a6bc1..ea63107 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -3,187 +3,451 @@ module Main where import Config (cProjectVersion) -import Control.Applicative ((<$>)) -import Control.Exception (Exception, Handler(..), ErrorCall(..)) -import CoreMonad (liftIO) -import qualified Control.Exception as E +import Control.Arrow +import Control.Applicative +import Control.Exception (Exception, Handler(..), catches, throw) import Data.Typeable (Typeable) import Data.Version (showVersion) +import Data.Default +import Data.List +import Data.Char (isSpace) import Language.Haskell.GhcMod +import Language.Haskell.GhcMod.Internal import Paths_ghc_mod import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import qualified System.Console.GetOpt as O -import System.Directory (doesFileExist) import System.Environment (getArgs) import System.Exit (exitFailure) -import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8) +import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8) +--import System.Process (rawSystem) +--import System.Exit (exitWith) +import Text.PrettyPrint ---------------------------------------------------------------- progVersion :: String -progVersion = "ghc-mod version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n" +progVersion = + "ghc-mod version " ++ showVersion version ++ " compiled by GHC " + ++ cProjectVersion ++ "\n" -ghcOptHelp :: String -ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] " +optionUsage :: (String -> String) -> [OptDescr a] -> [String] +optionUsage indent opts = concatMap optUsage opts + where + optUsage (Option so lo dsc udsc) = + [ concat $ intersperse ", " $ 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 = progVersion - ++ "Usage:\n" - ++ "\t ghc-mod list " ++ ghcOptHelp ++ "[-l] [-d]\n" - ++ "\t ghc-mod lang [-l]\n" - ++ "\t ghc-mod flag [-l]\n" - ++ "\t ghc-mod browse " ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [:] [[:] ...]\n" - ++ "\t ghc-mod check " ++ ghcOptHelp ++ "\n" - ++ "\t ghc-mod expand " ++ ghcOptHelp ++ "\n" - ++ "\t ghc-mod debug " ++ ghcOptHelp ++ "\n" - ++ "\t ghc-mod info " ++ ghcOptHelp ++ " \n" - ++ "\t ghc-mod type " ++ ghcOptHelp ++ " \n" - ++ "\t ghc-mod split " ++ ghcOptHelp ++ " \n" - ++ "\t ghc-mod sig " ++ ghcOptHelp ++ " \n" - ++ "\t ghc-mod refine " ++ ghcOptHelp ++ " \n" - ++ "\t ghc-mod auto " ++ ghcOptHelp ++ " \n" - ++ "\t ghc-mod find \n" - ++ "\t ghc-mod lint [-h opt] \n" - ++ "\t ghc-mod root\n" - ++ "\t ghc-mod doc \n" - ++ "\t ghc-mod boot\n" - ++ "\t ghc-mod version\n" - ++ "\t ghc-mod help\n" - ++ "\n" - ++ " for \"info\" and \"type\" is not used, anything is OK.\n" - ++ "It is necessary to maintain backward compatibility.\n" +usage = + "Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \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 | --help\n\ + \ Print this help message.\n\ + \\n\ + \ - list [FLAGS...]\n\ + \ List all visible modules.\n\ + \ Flags:\n\ + \ -d\n\ + \ Also print the modules' package.\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\ + \ -l\n\ + \ Option to be passed to hlint.\n\ + \\n\ + \ - root FILE\n\ + \ Try to find the project directory given FILE. For Cabal\n\ + \ projects this is the directory containing the cabal file, for\n\ + \ projects that use a cabal sandbox but have no cabal file this is the\n\ + \ directory containing the sandbox and otherwise this is the directory\n\ + \ containing FILE.\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\ + \ - boot\n\ + \ Internal command used by the emacs frontend.\n" + -- "\n\ + -- \The following forms are supported so ghc-mod can be invoked by\n\ + -- \`cabal repl':\n\ + -- \\n\ + -- \ ghc-mod --make GHC_OPTIONS\n\ + -- \ Pass all options through to the GHC executable.\n\ + -- \\n\ + -- \ ghc-mod --interactive GHC_OPTIONS [--ghc-mod]\n\ + -- \ Start ghci emulation mode. GHC_OPTIONS are passed to the\n\ + -- \ GHC API. If `--ghc-mod' is given ghc-mod specific extensions\n\ + -- \ are enabled.\n" + where + indent = (" "++) +cmdUsage :: String -> String -> String +cmdUsage cmd s = + let + -- Find command head + a = dropWhile (not . ((" - " ++ cmd) `isInfixOf`)) $ lines s + -- Take til the end of the current command block + b = flip takeWhile a $ \l -> + all isSpace l || (isIndented l && (isCurrCmdHead l || isNotCmdHead l)) + -- Drop extra newline from the end + c = dropWhileEnd (all isSpace) b + + isIndented = (" " `isPrefixOf`) + isNotCmdHead = ( not . (" - " `isPrefixOf`)) + isCurrCmdHead = ((" - " ++ cmd) `isPrefixOf`) + + unindent (' ':' ':' ':' ':l) = l + unindent l = l + in unlines $ unindent <$> c ---------------------------------------------------------------- -argspec :: [OptDescr (Options -> Options)] -argspec = - let option s l udsc dsc = Option s l dsc udsc - reqArg udsc dsc = ReqArg dsc udsc - in - [ option "l" ["tolisp"] "print as a list of Lisp" $ - NoArg $ \o -> o { outputStyle = LispStyle } +option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a +option s l udsc dsc = Option s l dsc udsc - , option "h" ["hlintOpt"] "hlint options" $ - reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o } +reqArg :: String -> (String -> a) -> ArgDescr a +reqArg udsc dsc = ReqArg dsc udsc - , option "g" ["ghcOpt"] "GHC options" $ - reqArg "ghcOpt" $ \g o -> - o { ghcUserOptions = g : ghcUserOptions o } - - , option "v" ["verbose"] "verbose" $ +globalArgSpec :: [OptDescr (Options -> Options)] +globalArgSpec = + [ option "v" ["verbose"] "Be more verbose." $ NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o } - , option "o" ["operators"] "print operators, too" $ - NoArg $ \o -> o { operators = True } + , option "l" ["tolisp"] "Format output as an S-Expression" $ + NoArg $ \o -> o { outputStyle = LispStyle } - , option "d" ["detailed"] "print detailed info" $ - NoArg $ \o -> o { detailed = True } + , option "b" ["boundary"] "Output line separator"$ + reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s } - , option "q" ["qualified"] "show qualified names" $ - NoArg $ \o -> o { qualified = True } + , option "g" ["ghcOpt"] "Option to be passed to GHC" $ + reqArg "OPT" $ \g o -> + o { ghcUserOptions = g : ghcUserOptions o } - , option "b" ["boundary"] "specify line separator (default is Nul string)"$ - reqArg "sep" $ \s o -> o { lineSeparator = LineSeparator s } + , option "" ["with-ghc"] "GHC executable to use" $ + reqArg "PROG" $ \p o -> o { ghcProgram = p } + + , option "" ["with-cabal"] "cabal-install executable to use" $ + reqArg "PROG" $ \p o -> o { cabalProgram = p } ] -parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) -parseArgs spec argv - = case O.getOpt Permute spec argv of - (o,n,[] ) -> (foldr id defaultOptions o, n) - (_,_,errs) -> E.throw (CmdArg errs) +parseGlobalArgs ::[String] -> (Options, [String]) +parseGlobalArgs argv + = case O.getOpt RequireOrder globalArgSpec argv of + (o,r,[] ) -> (foldr id defaultOptions o, r) + (_,_,errs) -> + fatalError $ "Parsing command line options failed: \n" ++ concat errs + +parseCommandArgs :: [OptDescr (Options -> Options)] + -> [String] + -> Options + -> (Options, [String]) +parseCommandArgs spec argv opts + = case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of + (o,r,[]) -> (foldr id opts o, r) + (_,_,errs) -> + fatalError $ "Parsing command options failed: \n" ++ concat errs ---------------------------------------------------------------- -data GHCModError = SafeList - | ArgumentsMismatch String - | NoSuchCommand String - | CmdArg [String] - | FileNotExist String deriving (Show, Typeable) +data CmdError = UnknownCommand String + | NoSuchFileError String + | LibraryError GhcModError -instance Exception GHCModError + deriving (Show, Typeable) + +instance Exception CmdError ---------------------------------------------------------------- +data InteractiveOptions = InteractiveOptions { + ghcModExtensions :: Bool + } + +instance Default InteractiveOptions where + def = InteractiveOptions False + +handler :: IO a -> IO a +handler = flip catches $ + [ Handler $ \(FatalError msg) -> exitError msg + , Handler $ \(InvalidCommandLine e) -> do + case e of + Left cmd -> + exitError $ (cmdUsage cmd usage) + ++ "\nghc-mod: Invalid command line form." + Right msg -> exitError msg + ] + main :: IO () -main = flip E.catches handlers $ do +main = handler $ do hSetEncoding stdout utf8 args <- getArgs - let (opt,cmdArg) = parseArgs argspec args - let cmdArg0 = cmdArg !. 0 - cmdArg1 = cmdArg !. 1 - cmdArg3 = cmdArg !. 3 - cmdArg4 = cmdArg !. 4 - cmdArg5 = cmdArg !. 5 - remainingArgs = tail cmdArg - nArgs :: Int -> a -> a - nArgs n f = if length remainingArgs == n - then f - else E.throw (ArgumentsMismatch cmdArg0) - (res, _) <- runGhcModT opt $ case cmdArg0 of - "list" -> modules - "lang" -> languages - "flag" -> flags - "browse" -> concat <$> mapM browse remainingArgs - "check" -> checkSyntax remainingArgs - "expand" -> expandTemplate remainingArgs - "debug" -> debugInfo - "info" -> nArgs 3 info cmdArg1 cmdArg3 - "type" -> nArgs 4 $ types cmdArg1 (read cmdArg3) (read cmdArg4) - "split" -> nArgs 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4) - "sig" -> nArgs 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4) - "refine" -> nArgs 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5 - "auto" -> nArgs 4 $ auto cmdArg1 (read cmdArg3) (read cmdArg4) - "find" -> nArgs 1 $ findSymbol cmdArg1 - "lint" -> nArgs 1 $ withFile lint cmdArg1 - "root" -> rootInfo - "doc" -> nArgs 1 $ pkgDoc cmdArg1 - "dumpsym" -> dumpSymbol - "boot" -> boot - "version" -> return progVersion - "help" -> return $ O.usageInfo usage argspec - cmd -> E.throw (NoSuchCommand cmd) - case res of - Right s -> putStr s - Left (GMENoMsg) -> - hPutStrLn stderr "Unknown error" - Left (GMEString msg) -> - hPutStrLn stderr msg - Left (GMECabalConfigure msg) -> - hPutStrLn stderr $ "cabal configure failed: " ++ show msg - Left (GMECabalFlags msg) -> - hPutStrLn stderr $ "retrieval of the cabal configuration flags failed: " ++ show msg - Left (GMEProcess cmd msg) -> - hPutStrLn stderr $ - "launching operating system process `"++c++"` failed: " ++ show msg - where c = unwords cmd + let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args + _realGhcArgs = filter (/="--ghc-mod") ghcArgs - where - handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)] - handleThenExit handler e = handler e >> exitFailure - handler1 :: ErrorCall -> IO () - handler1 = print -- for debug - handler2 :: GHCModError -> IO () - handler2 SafeList = printUsage - handler2 (ArgumentsMismatch cmd) = do - hPutStrLn stderr $ "\"" ++ cmd ++ "\": Arguments did not match" - printUsage - handler2 (NoSuchCommand cmd) = do - hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported" - printUsage - handler2 (CmdArg errs) = do - mapM_ (hPutStr stderr) errs - printUsage - handler2 (FileNotExist file) = do - hPutStrLn stderr $ "\"" ++ file ++ "\" not found" - printUsage - printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec - withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a - withFile cmd file = do - exist <- liftIO $ doesFileExist file - if exist - then cmd file - else E.throw (FileNotExist file) - xs !. idx - | length xs <= idx = E.throw SafeList - | otherwise = xs !! idx + (globalOptions,_cmdArgs) = parseGlobalArgs modArgs + + stripSeperator ("--":rest) = rest + stripSeperator l = l + + case args of + _ + -- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do + -- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith + + -- | "--interactive" `elem` ghcArgs -> do + -- let interactiveOptions = if "--ghc-mod" `elem` ghcArgs + -- then def { ghcModExtensions = True } + -- else def + + -- -- TODO: pass ghcArgs' to ghc API + -- putStrLn "\ninteractive\n" + -- --print realGhcArgs + -- (res, _) <- runGhcModT globalOptions $ undefined + -- case res of + -- Right s -> putStr s + -- Left e -> exitError $ render (gmeDoc e) + + + | otherwise -> do + (res, _) <- runGhcModT globalOptions $ commands args + case res of + Right s -> putStr s + Left e -> exitError $ render (gmeDoc e) + + -- Obtain ghc options by letting ourselfs be executed by + -- @cabal repl@ + -- TODO: need to do something about non-cabal projects + -- exe <- ghcModExecutable + -- let cabalArgs = ["repl", "-v0", "--with-ghc="++exe] + -- ++ (("--ghc-option="++) `map` ("--ghc-mod":"--":args)) + + -- print cabalArgs + + -- rawSystem "cabal" cabalArgs >>= exitWith + +commands :: IOish m => [String] -> GhcModT m String +commands [] = fatalError "No command given (try --help)\n" +commands (cmd:args) = fn args + where + fn = case cmd of + _ | cmd == "list" || cmd == "modules" -> modulesCmd + _ | cmd == "help" || cmd == "--help" -> const $ return usage + "version" -> const $ return progVersion + "lang" -> languagesCmd + "flag" -> flagsCmd + "browse" -> browseCmd + "check" -> checkSyntaxCmd + "expand" -> expandTemplateCmd + "debug" -> debugInfoCmd + "info" -> infoCmd + "type" -> typesCmd + "split" -> splitsCmd + "sig" -> sigCmd + "refine" -> refineCmd + "auto" -> autoCmd + "find" -> findSymbolCmd + "lint" -> lintCmd + "root" -> rootInfoCmd + "doc" -> pkgDocCmd + "dumpsym" -> dumpSymbolCmd + "boot" -> bootCmd + _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" + +newtype FatalError = FatalError String deriving (Show, Typeable) +instance Exception FatalError + +newtype InvalidCommandLine = InvalidCommandLine (Either String String) + deriving (Show, Typeable) +instance Exception InvalidCommandLine + +exitError :: String -> IO a +exitError msg = hPutStrLn stderr msg >> exitFailure + +fatalError :: String -> a +fatalError s = throw $ FatalError $ "ghc-mod: " ++ s + +withParseCmd :: IOish m + => [OptDescr (Options -> 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 + +modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd, + debugInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd, + findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd + :: IOish m => [String] -> GhcModT m String + +modulesCmd = withParseCmd [] $ \[] -> modules +languagesCmd = withParseCmd [] $ \[] -> languages +flagsCmd = withParseCmd [] $ \[] -> flags +debugInfoCmd = withParseCmd [] $ \[] -> debugInfo +rootInfoCmd = withParseCmd [] $ \[] -> rootInfo +-- internal +dumpSymbolCmd = withParseCmd [] $ \[] -> dumpSymbol +bootCmd = withParseCmd [] $ \[] -> boot + +findSymbolCmd = withParseCmd [] $ \[sym] -> findSymbol sym +pkgDocCmd = withParseCmd [] $ \[mdl] -> pkgDoc mdl +lintCmd = withParseCmd 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 expr + action [file,expr] = info file expr + action _ = throw $ InvalidCommandLine (Left "info") + +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 -> String -> a) -> [String] -> a +locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) expr +locAction' _ action [f, line,col,expr] = action f (read line) (read col) expr +locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd) + +hlintArgSpec :: [OptDescr (Options -> Options)] +hlintArgSpec = + [ option "h" ["hlintOpt"] "Option to be passed to hlint" $ + reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o } + ] +browseArgSpec :: [OptDescr (Options -> Options)] +browseArgSpec = + [ option "o" ["operators"] "Also print operators." $ + NoArg $ \o -> o { operators = True } + , option "d" ["detailed"] "Print symbols with accompanying signature." $ + NoArg $ \o -> o { detailed = True } + , option "q" ["qualified"] "Qualify symbols" $ + NoArg $ \o -> o { qualified = True } + ]