hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Rewrite ghc-mod command line frontend.

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Language/Haskell/GhcMod/CabalApi.hs
View File

@ -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"

16
Language/Haskell/GhcMod/Error.hs
View File

@ -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

23
Language/Haskell/GhcMod/Find.hs
View File

@ -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

7
Language/Haskell/GhcMod/Internal.hs
View File

@ -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

13
Language/Haskell/GhcMod/Types.hs
View File

@ -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

21
Language/Haskell/GhcMod/Utils.hs
View File

@ -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

5
ghc-mod.cabal
View File

@ -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

554
src/GHCMod.hs
View File

@ -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] [<package>:]<module> [[<package>:]<module> ...]\n"
++ "\t ghc-mod check " ++ ghcOptHelp ++ "<HaskellFiles...>\n"
++ "\t ghc-mod expand " ++ ghcOptHelp ++ "<HaskellFiles...>\n"
++ "\t ghc-mod debug " ++ ghcOptHelp ++ "\n"
++ "\t ghc-mod info " ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
++ "\t ghc-mod type " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ "\t ghc-mod split " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ "\t ghc-mod sig " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ "\t ghc-mod refine " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no> <expression>\n"
++ "\t ghc-mod auto " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ "\t ghc-mod find <symbol>\n"
++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
++ "\t ghc-mod root\n"
++ "\t ghc-mod doc <module>\n"
++ "\t ghc-mod boot\n"
++ "\t ghc-mod version\n"
++ "\t ghc-mod help\n"
++ "\n"
++ "<module> 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<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)]
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 }
]