Rewrite ghc-mod command line frontend.

This commit is contained in:
Daniel Gröber 2014-09-18 10:05:47 +02:00
parent 34dd8c5bd9
commit 5a4bec8755
8 changed files with 470 additions and 173 deletions

View File

@ -31,7 +31,7 @@ import qualified Distribution.PackageDescription as P
import Distribution.PackageDescription.Configuration (finalizePackageDescription) import Distribution.PackageDescription.Configuration (finalizePackageDescription)
import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.PackageDescription.Parse (readPackageDescription)
import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..)) 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.Simple.Program.Types (programName, programFindVersion)
import Distribution.System (buildPlatform) import Distribution.System (buildPlatform)
import Distribution.Text (display) import Distribution.Text (display)
@ -155,7 +155,7 @@ getGHCId = CompilerId GHC <$> getGHC
getGHC :: IO Version getGHC :: IO Version
getGHC = do getGHC = do
mv <- programFindVersion ghcProgram silent (programName ghcProgram) mv <- programFindVersion C.ghcProgram silent (programName C.ghcProgram)
case mv of case mv of
-- TODO: MonadError it up -- TODO: MonadError it up
Nothing -> E.throwIO $ userError "ghc not found" Nothing -> E.throwIO $ userError "ghc not found"

View File

@ -1,6 +1,7 @@
{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
module Language.Haskell.GhcMod.Error ( module Language.Haskell.GhcMod.Error (
GhcModError(..) GhcModError(..)
, gmeDoc
, modifyError , modifyError
, modifyError' , modifyError'
, tryFix , tryFix
@ -10,6 +11,7 @@ module Language.Haskell.GhcMod.Error (
import Control.Monad.Error (MonadError(..), Error(..)) import Control.Monad.Error (MonadError(..), Error(..))
import Exception import Exception
import Text.PrettyPrint
data GhcModError = GMENoMsg data GhcModError = GMENoMsg
-- ^ Unknown error -- ^ Unknown error
@ -29,6 +31,20 @@ instance Error GhcModError where
noMsg = GMENoMsg noMsg = GMENoMsg
strMsg = GMEString 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 :: MonadError e m => (e -> e) -> m a -> m a
modifyError f action = action `catchError` \e -> throwError $ f e modifyError f action = action `catchError` \e -> throwError $ f e

View File

@ -31,9 +31,8 @@ import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Name (getOccString) import Name (getOccString)
import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime) import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime)
import System.FilePath ((</>), takeDirectory) import System.FilePath ((</>))
import System.IO import System.IO
import System.Environment
#ifndef MIN_VERSION_containers #ifndef MIN_VERSION_containers
#define MIN_VERSION_containers(x,y,z) 1 #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 :: (IOish m, MonadError GhcModError m) => m SymbolDb
loadSymbolDb = SymbolDb <$> readSymbolDb 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 :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString])
readSymbolDb = do readSymbolDb = do
ghcMod <- liftIO ghcModExecutable ghcMod <- liftIO ghcModExecutable

View File

@ -16,8 +16,9 @@ module Language.Haskell.GhcMod.Internal (
, cabalDependPackages , cabalDependPackages
, cabalSourceDirs , cabalSourceDirs
, cabalAllTargets , cabalAllTargets
-- * GHC.Paths -- * Various Paths
, ghcLibDir , ghcLibDir
, ghcModExecutable
-- * IO -- * IO
, getDynamicFlags , getDynamicFlags
-- * Targets -- * Targets
@ -42,6 +43,8 @@ module Language.Haskell.GhcMod.Internal (
, getCompilerMode , getCompilerMode
, setCompilerMode , setCompilerMode
, withOptions , withOptions
-- * 'GhcModError'
, gmeDoc
-- * 'GhcMonad' Choice -- * 'GhcMonad' Choice
, (||>) , (||>)
, goNext , goNext
@ -52,11 +55,13 @@ import GHC.Paths (libdir)
import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Logger
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
-- | Obtaining the directory for ghc system libraries. -- | Obtaining the directory for ghc system libraries.
ghcLibDir :: FilePath ghcLibDir :: FilePath

View File

@ -25,7 +25,12 @@ newtype LineSeparator = LineSeparator String
data Options = Options { data Options = Options {
outputStyle :: OutputStyle 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 -- | GHC command line options set on the @ghc-mod@ command line
, ghcUserOptions:: [GHCOption] , ghcUserOptions:: [GHCOption]
-- | If 'True', 'browse' also returns operators. -- | If 'True', 'browse' also returns operators.
@ -34,15 +39,17 @@ data Options = Options {
, detailed :: Bool , detailed :: Bool
-- | If 'True', 'browse' will return fully qualified name -- | If 'True', 'browse' will return fully qualified name
, qualified :: Bool , qualified :: Bool
-- | Line separator string. , hlintOpts :: [String]
, lineSeparator :: LineSeparator
} }
-- | A default 'Options'. -- | A default 'Options'.
defaultOptions :: Options defaultOptions :: Options
defaultOptions = Options { defaultOptions = Options {
outputStyle = PlainStyle outputStyle = PlainStyle
, hlintOpts = [] , hlintOpts = []
, ghcProgram = "ghc"
, cabalProgram = "cabal"
, ghcUserOptions= [] , ghcUserOptions= []
, operators = False , operators = False
, detailed = False , detailed = False

View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Utils where module Language.Haskell.GhcMod.Utils where
@ -6,6 +7,9 @@ import MonadUtils (MonadIO, liftIO)
import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Directory (getCurrentDirectory, setCurrentDirectory)
import System.Exit (ExitCode(..)) import System.Exit (ExitCode(..))
import System.Process (readProcessWithExitCode) import System.Process (readProcessWithExitCode)
#ifndef SPEC
import System.Environment
#endif
-- dropWhileEnd is not provided prior to base 4.5.0.0. -- dropWhileEnd is not provided prior to base 4.5.0.0.
dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd :: (a -> Bool) -> [a] -> [a]
@ -42,3 +46,20 @@ withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
withDirectory_ dir action = withDirectory_ dir action =
gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action) (\_ -> 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

View File

@ -106,6 +106,7 @@ Library
, io-choice , io-choice
, monad-journal >= 0.4 , monad-journal >= 0.4
, old-time , old-time
, pretty
, process , process
, syb , syb
, time , time
@ -134,8 +135,11 @@ Executable ghc-mod
Default-Extensions: ConstraintKinds, FlexibleContexts Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src HS-Source-Dirs: src
Build-Depends: base >= 4.0 && < 5 Build-Depends: base >= 4.0 && < 5
, data-default
, directory , directory
, filepath , filepath
, pretty
, process
, mtl >= 2.0 , mtl >= 2.0
, ghc , ghc
, ghc-mod , ghc-mod
@ -199,6 +203,7 @@ Test-Suite spec
, io-choice , io-choice
, monad-journal >= 0.4 , monad-journal >= 0.4
, old-time , old-time
, pretty
, process , process
, syb , syb
, time , time

View File

@ -3,187 +3,451 @@
module Main where module Main where
import Config (cProjectVersion) import Config (cProjectVersion)
import Control.Applicative ((<$>)) import Control.Arrow
import Control.Exception (Exception, Handler(..), ErrorCall(..)) import Control.Applicative
import CoreMonad (liftIO) import Control.Exception (Exception, Handler(..), catches, throw)
import qualified Control.Exception as E
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Data.Version (showVersion) import Data.Version (showVersion)
import Data.Default
import Data.List
import Data.Char (isSpace)
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal
import Paths_ghc_mod import Paths_ghc_mod
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
import qualified System.Console.GetOpt as O import qualified System.Console.GetOpt as O
import System.Directory (doesFileExist)
import System.Environment (getArgs) import System.Environment (getArgs)
import System.Exit (exitFailure) 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 :: 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 optionUsage :: (String -> String) -> [OptDescr a] -> [String]
ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] " 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 :: String
usage = progVersion usage =
++ "Usage:\n" "Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\
++ "\t ghc-mod list " ++ ghcOptHelp ++ "[-l] [-d]\n" \*Global Options (OPTIONS)*\n\
++ "\t ghc-mod lang [-l]\n" \ Global options can be specified before and after the command and\n\
++ "\t ghc-mod flag [-l]\n" \ interspersed with command specific options\n\
++ "\t ghc-mod browse " ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [<package>:]<module> [[<package>:]<module> ...]\n" \\n"
++ "\t ghc-mod check " ++ ghcOptHelp ++ "<HaskellFiles...>\n" ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
++ "\t ghc-mod expand " ++ ghcOptHelp ++ "<HaskellFiles...>\n" "*Commands*\n\
++ "\t ghc-mod debug " ++ ghcOptHelp ++ "\n" \ - version\n\
++ "\t ghc-mod info " ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n" \ Print the version of the program.\n\
++ "\t ghc-mod type " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n" \\n\
++ "\t ghc-mod split " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n" \ - help | --help\n\
++ "\t ghc-mod sig " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n" \ Print this help message.\n\
++ "\t ghc-mod refine " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no> <expression>\n" \\n\
++ "\t ghc-mod auto " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n" \ - list [FLAGS...]\n\
++ "\t ghc-mod find <symbol>\n" \ List all visible modules.\n\
++ "\t ghc-mod lint [-h opt] <HaskellFile>\n" \ Flags:\n\
++ "\t ghc-mod root\n" \ -d\n\
++ "\t ghc-mod doc <module>\n" \ Also print the modules' package.\n\
++ "\t ghc-mod boot\n" \\n\
++ "\t ghc-mod version\n" \ - lang\n\
++ "\t ghc-mod help\n" \ List all known GHC language extensions.\n\
++ "\n" \\n\
++ "<module> for \"info\" and \"type\" is not used, anything is OK.\n" \ - flag\n\
++ "It is necessary to maintain backward compatibility.\n" \ List GHC -f<bla> 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)] option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a
argspec = option s l udsc dsc = Option s l dsc udsc
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 "h" ["hlintOpt"] "hlint options" $ reqArg :: String -> (String -> a) -> ArgDescr a
reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o } reqArg udsc dsc = ReqArg dsc udsc
, option "g" ["ghcOpt"] "GHC options" $ globalArgSpec :: [OptDescr (Options -> Options)]
reqArg "ghcOpt" $ \g o -> globalArgSpec =
o { ghcUserOptions = g : ghcUserOptions o } [ option "v" ["verbose"] "Be more verbose." $
, option "v" ["verbose"] "verbose" $
NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o } NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o }
, option "o" ["operators"] "print operators, too" $ , option "l" ["tolisp"] "Format output as an S-Expression" $
NoArg $ \o -> o { operators = True } NoArg $ \o -> o { outputStyle = LispStyle }
, option "d" ["detailed"] "print detailed info" $ , option "b" ["boundary"] "Output line separator"$
NoArg $ \o -> o { detailed = True } reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s }
, option "q" ["qualified"] "show qualified names" $ , option "g" ["ghcOpt"] "Option to be passed to GHC" $
NoArg $ \o -> o { qualified = True } reqArg "OPT" $ \g o ->
o { ghcUserOptions = g : ghcUserOptions o }
, option "b" ["boundary"] "specify line separator (default is Nul string)"$ , option "" ["with-ghc"] "GHC executable to use" $
reqArg "sep" $ \s o -> o { lineSeparator = LineSeparator s } 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]) parseGlobalArgs ::[String] -> (Options, [String])
parseArgs spec argv parseGlobalArgs argv
= case O.getOpt Permute spec argv of = case O.getOpt RequireOrder globalArgSpec argv of
(o,n,[] ) -> (foldr id defaultOptions o, n) (o,r,[] ) -> (foldr id defaultOptions o, r)
(_,_,errs) -> E.throw (CmdArg errs) (_,_,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 data CmdError = UnknownCommand String
| ArgumentsMismatch String | NoSuchFileError String
| NoSuchCommand String | LibraryError GhcModError
| CmdArg [String]
| FileNotExist String deriving (Show, Typeable)
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 :: IO ()
main = flip E.catches handlers $ do main = handler $ do
hSetEncoding stdout utf8 hSetEncoding stdout utf8
args <- getArgs 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 let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args
Right s -> putStr s _realGhcArgs = filter (/="--ghc-mod") ghcArgs
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
where (globalOptions,_cmdArgs) = parseGlobalArgs modArgs
handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
handleThenExit handler e = handler e >> exitFailure stripSeperator ("--":rest) = rest
handler1 :: ErrorCall -> IO () stripSeperator l = l
handler1 = print -- for debug
handler2 :: GHCModError -> IO () case args of
handler2 SafeList = printUsage _
handler2 (ArgumentsMismatch cmd) = do -- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do
hPutStrLn stderr $ "\"" ++ cmd ++ "\": Arguments did not match" -- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith
printUsage
handler2 (NoSuchCommand cmd) = do -- | "--interactive" `elem` ghcArgs -> do
hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported" -- let interactiveOptions = if "--ghc-mod" `elem` ghcArgs
printUsage -- then def { ghcModExtensions = True }
handler2 (CmdArg errs) = do -- else def
mapM_ (hPutStr stderr) errs
printUsage -- -- TODO: pass ghcArgs' to ghc API
handler2 (FileNotExist file) = do -- putStrLn "\ninteractive\n"
hPutStrLn stderr $ "\"" ++ file ++ "\" not found" -- --print realGhcArgs
printUsage -- (res, _) <- runGhcModT globalOptions $ undefined
printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec -- case res of
withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a -- Right s -> putStr s
withFile cmd file = do -- Left e -> exitError $ render (gmeDoc e)
exist <- liftIO $ doesFileExist file
if exist
then cmd file | otherwise -> do
else E.throw (FileNotExist file) (res, _) <- runGhcModT globalOptions $ commands args
xs !. idx case res of
| length xs <= idx = E.throw SafeList Right s -> putStr s
| otherwise = xs !! idx 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 }
]