Start migrating ghc-modi code to src/GHCMod.hs

This commit is contained in:
Daniel Gröber 2014-10-23 00:56:18 +02:00
parent 34dd9de83c
commit ff75811a76
3 changed files with 179 additions and 36 deletions

View File

@ -136,11 +136,13 @@ 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
, async
, data-default , data-default
, directory , directory
, filepath , filepath
, pretty , pretty
, process , process
, split
, mtl >= 2.0 , mtl >= 2.0
, ghc , ghc
, ghc-mod , ghc-mod

View File

@ -1,34 +1,47 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
module Main where module Main where
import Config (cProjectVersion) import Config (cProjectVersion)
import MonadUtils (liftIO)
import Control.Applicative import Control.Applicative
import Control.Exception (Exception, Handler(..), catches, throw) import Control.Monad
import Control.Exception ( SomeException(..), fromException, Exception
, Handler(..), catches, throw)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Data.Version (showVersion) import Data.Version (showVersion)
import Data.Default import Data.Default
import Data.List import Data.List
import Data.List.Split
import Data.Maybe
import Data.Char (isSpace) import Data.Char (isSpace)
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal 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.Environment (getArgs) import System.Directory (setCurrentDirectory)
import System.Environment (getArgs,getProgName)
import System.Exit (exitFailure) import System.Exit (exitFailure)
import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8) import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush)
--import System.Process (rawSystem) import System.IO.Unsafe (unsafePerformIO)
--import System.Exit (exitWith) import System.FilePath (takeFileName)
import System.Exit (ExitCode, exitSuccess)
import Text.PrettyPrint import Text.PrettyPrint
---------------------------------------------------------------- import Misc
progVersion :: String progVersion :: String
progVersion = progVersion =
"ghc-mod version " ++ showVersion version ++ " compiled by GHC " progName ++ " version " ++ showVersion version ++ " compiled by GHC "
++ cProjectVersion ++ "\n" ++ cProjectVersion ++ "\n"
-- TODO: remove (ghc) version prefix!
progName :: String
progName = unsafePerformIO $ takeFileName <$> getProgName
optionUsage :: (String -> String) -> [OptDescr a] -> [String] optionUsage :: (String -> String) -> [OptDescr a] -> [String]
optionUsage indent opts = concatMap optUsage opts optionUsage indent opts = concatMap optUsage opts
where where
@ -52,9 +65,15 @@ optionUsage indent opts = concatMap optUsage opts
ReqArg _ label -> s ++ label ReqArg _ label -> s ++ label
OptArg _ label -> s ++ "["++label++"]" OptArg _ label -> s ++ "["++label++"]"
-- TODO: Generate the stuff below automatically
usage :: String usage :: String
usage = usage =
case progName of
"ghc-modi" -> ghcModiUsage
_ -> ghcModUsage
-- TODO: Generate the stuff below automatically
ghcModUsage :: String
ghcModUsage =
"Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\ "Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\
\*Global Options (OPTIONS)*\n\ \*Global Options (OPTIONS)*\n\
\ Global options can be specified before and after the command and\n\ \ Global options can be specified before and after the command and\n\
@ -62,7 +81,7 @@ usage =
\\n" \\n"
++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++ ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
"*Commands*\n\ "*Commands*\n\
\ - version\n\ \ - version | --version\n\
\ Print the version of the program.\n\ \ Print the version of the program.\n\
\\n\ \\n\
\ - help | --help\n\ \ - help | --help\n\
@ -194,6 +213,23 @@ usage =
where where
indent = (" "++) indent = (" "++)
ghcModiUsage :: String
ghcModiUsage =
"Usage: ghc-modi [OPTIONS...] COMMAND\n\
\*Options*\n"
++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
"*Commands*\n\
\ - version | --version\n\
\ Print the version of the program.\n\
\\n\
\ - help | --help\n\
\ Print this help message.\n"
where
indent = (" "++)
cmdUsage :: String -> String -> String cmdUsage :: String -> String -> String
cmdUsage cmd s = cmdUsage cmd s =
let let
@ -242,12 +278,13 @@ globalArgSpec =
reqArg "PROG" $ \p o -> o { cabalProgram = p } reqArg "PROG" $ \p o -> o { cabalProgram = p }
] ]
parseGlobalArgs ::[String] -> (Options, [String])
parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
parseGlobalArgs argv parseGlobalArgs argv
= case O.getOpt RequireOrder globalArgSpec argv of = case O.getOpt RequireOrder globalArgSpec argv of
(o,r,[] ) -> (foldr id defaultOptions o, r) (o,r,[] ) -> Right $ (foldr id defaultOptions o, r)
(_,_,errs) -> (_,_,errs) -> Left $ InvalidCommandLine $ Right $
fatalError $ "Parsing command line options failed: \n" ++ concat errs "Parsing command line options failed: " ++ concat errs
parseCommandArgs :: [OptDescr (Options -> Options)] parseCommandArgs :: [OptDescr (Options -> Options)]
-> [String] -> [String]
@ -257,7 +294,7 @@ parseCommandArgs spec argv opts
= case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of = case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of
(o,r,[]) -> (foldr id opts o, r) (o,r,[]) -> (foldr id opts o, r)
(_,_,errs) -> (_,_,errs) ->
fatalError $ "Parsing command options failed: \n" ++ concat errs fatalError $ "Parsing command options failed: " ++ concat errs
---------------------------------------------------------------- ----------------------------------------------------------------
@ -284,9 +321,9 @@ handler = flip catches $
, Handler $ \(InvalidCommandLine e) -> do , Handler $ \(InvalidCommandLine e) -> do
case e of case e of
Left cmd -> Left cmd ->
exitError $ (cmdUsage cmd usage) exitError $ (cmdUsage cmd ghcModUsage) ++ "\n"
++ "\nghc-mod: Invalid command line form." ++ progName ++ ": Invalid command line form."
Right msg -> exitError msg Right msg -> exitError $ progName ++ ": " ++ msg
] ]
main :: IO () main :: IO ()
@ -294,6 +331,20 @@ main = handler $ do
hSetEncoding stdout utf8 hSetEncoding stdout utf8
args <- getArgs args <- getArgs
-- This doesn't handle --help and --version being given after any global
-- options. To do that we'd have to fiddle with getOpt.
case parseGlobalArgs args of
Left e -> case globalCommands args of
Just s -> putStr s
Nothing -> throw e
Right res@(_,cmdArgs) ->
case globalCommands cmdArgs of
Just s -> putStr s
Nothing -> progMain res
progMain :: (Options,[String]) -> IO ()
progMain (globalOptions,cmdArgs) = do
-- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args -- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args
-- _realGhcArgs = filter (/="--ghc-mod") ghcArgs -- _realGhcArgs = filter (/="--ghc-mod") ghcArgs
@ -302,7 +353,11 @@ main = handler $ do
-- stripSeperator ("--":rest) = rest -- stripSeperator ("--":rest) = rest
-- stripSeperator l = l -- stripSeperator l = l
case args of case progName of
"ghc-modi" -> do
legacyInteractive globalOptions =<< emptyNewUnGetLine
_ _
-- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do -- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do
-- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith -- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith
@ -322,14 +377,9 @@ main = handler $ do
| otherwise -> do | otherwise -> do
let (globalOptions,cmdArgs) = parseGlobalArgs args (res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs
res <- simpleCommands cmdArgs case res of
putStr =<< case res of Right s -> putStr s
Just s -> return s
Nothing -> do
(res',_) <- runGhcModT globalOptions $ ghcCommands cmdArgs
case res' of
Right s -> return s
Left e -> exitError $ render (gmeDoc e) Left e -> exitError $ render (gmeDoc e)
-- Obtain ghc options by letting ourselfs be executed by -- Obtain ghc options by letting ourselfs be executed by
@ -343,15 +393,102 @@ main = handler $ do
-- rawSystem "cabal" cabalArgs >>= exitWith -- rawSystem "cabal" cabalArgs >>= exitWith
simpleCommands :: [String] -> IO (Maybe String)
simpleCommands [] = return Nothing
simpleCommands (cmd:_) = return $ case cmd of -- ghc-modi
legacyInteractive :: Options -> UnGetLine -> IO ()
legacyInteractive opt ref = flip catches handlers $ do
(res,_) <- runGhcModT opt $ do
symdbreq <- liftIO $ newSymDbReq opt
world <- liftIO . getCurrentWorld =<< cradle
legacyInteractiveLoop symdbreq ref world
case res of
Right () -> return ()
Left e -> putStrLn $ notGood $ render (gmeDoc e)
where
handlers = [ Handler $ \Restart -> legacyInteractive opt ref ]
isExitCodeException :: SomeException -> Bool
isExitCodeException e = isJust mExitCode
where
mExitCode :: Maybe ExitCode
mExitCode = fromException e
bug :: String -> IO ()
bug msg = do
putStrLn $ notGood $ "BUG: " ++ msg
exitFailure
notGood :: String -> String
notGood msg = "NG " ++ escapeNewlines msg
escapeNewlines :: String -> String
escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"
replace :: String -> String -> String -> String
replace needle replacement = intercalate replacement . splitOn needle
legacyInteractiveLoop :: IOish m
=> SymDbReq -> UnGetLine -> World -> GhcModT m ()
legacyInteractiveLoop symdbreq ref world = do
liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
-- blocking
cmdArg <- liftIO $ getCommand ref
-- after blocking, we need to see if the world has changed.
changed <- liftIO . isWorldChanged world =<< cradle
when changed $ do
liftIO $ ungetCommand ref cmdArg
throw Restart
liftIO . prepareAutogen =<< cradle
let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg
arg = concat args'
cmd = dropWhileEnd isSpace cmd'
args = dropWhileEnd isSpace `map` args'
res <- case dropWhileEnd isSpace cmd of
"check" -> checkSyntaxCmd [arg]
"lint" -> lintCmd [arg]
"find" -> do
db <- getDb symdbreq >>= checkDb symdbreq
lookupSymbol arg db
"info" -> infoCmd [head args, concat $ tail args']
"type" -> typesCmd args
"split" -> splitsCmd args
"sig" -> sigCmd args
"auto" -> autoCmd args
"refine" -> refineCmd args
"boot" -> bootCmd []
"browse" -> browseCmd args
"quit" -> liftIO $ exitSuccess
"" -> liftIO $ exitSuccess
_ -> fatalError $ "unknown command: `" ++ cmd ++ "'"
liftIO $ putStr res >> putStrLn "OK" >> hFlush stdout
legacyInteractiveLoop symdbreq ref world
globalCommands :: [String] -> Maybe String
globalCommands [] = Nothing
globalCommands (cmd:_) = case cmd of
_ | cmd == "help" || cmd == "--help" -> Just usage _ | cmd == "help" || cmd == "--help" -> Just usage
"version" -> Just progVersion _ | cmd == "version" || cmd == "--version" -> Just progVersion
_ -> Nothing _ -> Nothing
ghcCommands :: IOish m => [String] -> GhcModT m String ghcCommands :: IOish m => [String] -> GhcModT m String
ghcCommands [] = fatalError "No command given (try --help)\n" ghcCommands [] = fatalError "No command given (try --help)"
ghcCommands (cmd:args) = fn args ghcCommands (cmd:args) = fn args
where where
fn = case cmd of fn = case cmd of
@ -387,7 +524,7 @@ exitError :: String -> IO a
exitError msg = hPutStrLn stderr msg >> exitFailure exitError msg = hPutStrLn stderr msg >> exitFailure
fatalError :: String -> a fatalError :: String -> a
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s fatalError s = throw $ FatalError $ progName ++ ": " ++ s
withParseCmd :: IOish m withParseCmd :: IOish m
=> [OptDescr (Options -> Options)] => [OptDescr (Options -> Options)]

View File

@ -1,5 +1,9 @@
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
-- | WARNING
-- This program in the process of being deprecated, use `ghc-mod --interactive`
-- instead.
-- Commands: -- Commands:
-- check <file> -- check <file>
-- find <symbol> -- find <symbol>