ghc-mod/src/GHCMod.hs

288 lines
9.9 KiB
Haskell
Raw Normal View History

{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
2010-06-14 06:38:56 +00:00
2010-01-06 05:38:06 +00:00
module Main where
import Control.Category
import Control.Applicative
import Control.Monad
2014-03-27 05:46:33 +00:00
import Data.Typeable (Typeable)
import Data.List
import Data.List.Split
import Data.Char (isSpace)
2015-08-10 08:10:33 +00:00
import Data.Maybe
import Exception
2013-05-17 01:00:01 +00:00
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad
2015-08-10 08:10:33 +00:00
import System.FilePath ((</>))
import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
removeDirectoryRecursive)
2015-12-05 20:55:12 +00:00
-- import System.Environment (getArgs)
2015-09-01 02:14:15 +00:00
import System.IO
2015-08-18 02:50:19 +00:00
import System.Exit
2015-12-05 20:55:12 +00:00
import Text.PrettyPrint hiding ((<>))
import Prelude hiding ((.))
2015-12-05 20:55:12 +00:00
import GHCMod.Options
2010-01-06 05:38:06 +00:00
import Misc
ghcModStyle :: Style
ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
----------------------------------------------------------------
2014-09-12 22:09:57 +00:00
{-
File map docs:
CLI options:
* `--map-file "file1.hs=file2.hs"` can be used to tell
ghc-mod that it should take source code for `file1.hs` from `file2.hs`.
`file1.hs` can be either full path, or path relative to project root.
2015-08-19 02:28:26 +00:00
`file2.hs` has to be either relative to project root,
or full path (preferred).
* `--map-file "file.hs"` can be used to tell ghc-mod that it should take
source code for `file.hs` from stdin. File end marker is `\EOT\n`,
i.e. `\x04\x0A`. `file.hs` may or may not exist, and should be
either full path, or relative to project root.
Interactive commands:
* `map-file file.hs` -- tells ghc-modi to read `file.hs` source from stdin.
Works the same as second form of `--map-file` CLI option.
* `unmap-file file.hs` -- unloads previously mapped file, so that it's
no longer mapped. `file.hs` can be full path or relative to
project root, either will work.
Exposed functions:
* `loadMappedFile :: FilePath -> FilePath -> GhcModT m ()` -- maps `FilePath`,
given as first argument to take source from `FilePath` given as second
argument. Works exactly the same as first form of `--map-file`
CLI option.
* `loadMappedFileSource :: FilePath -> String -> GhcModT m ()` -- maps
`FilePath`, given as first argument to have source as given
by second argument. Works exactly the same as second form of `--map-file`
CLI option, sans reading from stdin.
* `unloadMappedFile :: FilePath -> GhcModT m ()` -- unmaps `FilePath`, given as
first argument, and removes any temporary files created when file was
mapped. Works exactly the same as `unmap-file` interactive command
-}
2010-06-14 06:38:56 +00:00
----------------------------------------------------------------
data CmdError = UnknownCommand String
| NoSuchFileError String
| LibraryError GhcModError
2010-06-14 06:38:56 +00:00
deriving (Show, Typeable)
instance Exception CmdError
2010-01-06 05:38:06 +00:00
data InteractiveOptions = InteractiveOptions {
ghcModExtensions :: Bool
}
2015-08-14 03:57:33 +00:00
handler :: IOish m => GhcModT m a -> GhcModT m a
handler = flip gcatches $
[ GHandler $ \(FatalError msg) -> exitError msg
2015-08-18 02:50:19 +00:00
, GHandler $ \e@(ExitSuccess) -> throw e
, GHandler $ \e@(ExitFailure _) -> throw e
2015-08-14 03:57:33 +00:00
, GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e
]
2010-01-06 05:38:06 +00:00
main :: IO ()
2015-08-14 03:57:33 +00:00
main = do
2013-03-29 12:58:55 +00:00
hSetEncoding stdout utf8
2015-12-05 20:55:12 +00:00
parseArgs >>= \res@(globalOptions, _) ->
catches (progMain res) [
Handler $ \(e :: GhcModError) ->
runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
]
2015-12-05 20:55:12 +00:00
progMain :: (Options, GhcModCommands) -> IO ()
progMain (globalOptions, commands) = runGmOutT globalOptions $
wrapGhcCommands globalOptions commands
-- ghc-modi
legacyInteractive :: IOish m => GhcModT m ()
legacyInteractive = do
opt <- options
prepareCabalHelper
tmpdir <- cradleTempDir <$> cradle
gmo <- gmoAsk
symdbreq <- liftIO $ newSymDbReq opt gmo tmpdir
world <- getCurrentWorld
legacyInteractiveLoop symdbreq world
bug :: IOish m => String -> GhcModT m ()
bug msg = do
gmPutStrLn $ notGood $ "BUG: " ++ msg
liftIO 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 -> World -> GhcModT m ()
legacyInteractiveLoop symdbreq world = do
liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
-- blocking
cmdArg <- liftIO $ getLine
-- after blocking, we need to see if the world has changed.
changed <- didWorldChange world
world' <- if changed
then getCurrentWorld -- TODO: gah, we're hitting the fs twice
else return world
when changed $ do
dropSession
let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg
arg = concat args'
cmd = dropWhileEnd isSpace cmd'
args = dropWhileEnd isSpace `map` args'
res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of
2015-12-05 20:55:12 +00:00
"check" -> checkSyntax [arg]
"lint" -> lint defaultLintOpts arg
"find" -> do
db <- getDb symdbreq >>= checkDb symdbreq
lookupSymbol arg db
2015-12-05 20:55:12 +00:00
"info" -> info (head args) $ Expression $ concat $ tail args'
"type" -> locArgs types args
"split" -> locArgs splits args
2015-12-05 20:55:12 +00:00
"sig" -> locArgs sig args
"auto" -> locArgs auto args
"refine" -> locArgs' refine args
2015-12-05 20:55:12 +00:00
"boot" -> boot
"browse" -> concat <$> browse defaultBrowseOpts `mapM` args
"map-file" -> liftIO getFileSourceFromStdin
>>= loadMappedFileSource arg
>> return ""
"unmap-file" -> unloadMappedFile arg
>> return ""
"quit" -> liftIO $ exitSuccess
"" -> liftIO $ exitSuccess
_ -> fatalError $ "unknown command: `" ++ cmd ++ "'"
gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
legacyInteractiveLoop symdbreq world'
where
2015-12-05 20:55:12 +00:00
interactiveHandlers =
[ GHandler $ \e@(FatalError _) -> throw e
2015-08-18 02:50:19 +00:00
, GHandler $ \e@(ExitSuccess) -> throw e
, GHandler $ \e@(ExitFailure _) -> throw e
, GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return ""
]
2015-12-06 16:47:11 +00:00
locArgs a [f,l,c] = a f (read l) (read c)
locArgs _ args = throw $ InvalidCommandLine $ Left $ unwords args
locArgs' a (f:l:c:xs) = a f (read l) (read c) (Expression $ unwords xs)
locArgs' _ args = throw $ InvalidCommandLine $ Left $ unwords args
2015-10-03 14:00:46 +00:00
getFileSourceFromStdin :: IO String
getFileSourceFromStdin = do
2015-10-01 06:54:13 +00:00
linesIn <- readStdin'
return (intercalate "\n" linesIn)
where
readStdin' = do
x <- getLine
if x/="\EOT"
then fmap (x:) readStdin'
else return []
-- Someone please already rewrite the cmdline parsing code *weep* :'(
2015-12-05 20:55:12 +00:00
wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()
wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo
wrapGhcCommands opts cmd = do
handleGmError $ runGhcModT opts $ handler $ do
forM_ (reverse $ optFileMappings opts) $
uncurry loadMMappedFiles
2015-12-05 20:55:12 +00:00
gmPutStr =<< ghcCommands cmd
where
handleGmError action = do
(e, _l) <- liftIO . evaluate =<< action
case e of
Right _ ->
return ()
Left ed ->
exitError $ renderStyle ghcModStyle (gmeDoc ed)
loadMMappedFiles from (Just to) = loadMappedFile from to
loadMMappedFiles from (Nothing) = do
src <- liftIO getFileSourceFromStdin
loadMappedFileSource from src
2015-12-05 20:55:12 +00:00
ghcCommands :: IOish m => GhcModCommands -> GhcModT m String
-- ghcCommands cmd = action args
ghcCommands (CmdLang) = languages
ghcCommands (CmdFlag) = flags
ghcCommands (CmdDebug) = debugInfo
ghcCommands (CmdDebugComponent ts) = componentInfo ts
ghcCommands (CmdBoot) = boot
-- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""
-- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands
ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""
ghcCommands (CmdModules detail) = modules detail
ghcCommands (CmdDumpSym tmpdir) = dumpSymbol tmpdir
ghcCommands (CmdFind symb) = findSymbol symb
ghcCommands (CmdDoc m) = pkgDoc m
ghcCommands (CmdLint opts file) = lint opts file
ghcCommands (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms
ghcCommands (CmdCheck files) = checkSyntax files
ghcCommands (CmdExpand files) = expandTemplate files
ghcCommands (CmdInfo file symb) = info file $ Expression symb
ghcCommands (CmdType file (line, col)) = types file line col
ghcCommands (CmdSplit file (line, col)) = splits file line col
ghcCommands (CmdSig file (line, col)) = sig file line col
ghcCommands (CmdAuto file (line, col)) = auto file line col
ghcCommands (CmdRefine file (line, col) expr) = refine file line col $ Expression expr
ghcCommands _ = fatalError "Unknown command"
newtype FatalError = FatalError String deriving (Show, Typeable)
instance Exception FatalError
newtype InvalidCommandLine = InvalidCommandLine (Either String String)
deriving (Show, Typeable)
instance Exception InvalidCommandLine
exitError :: (MonadIO m, GmOut m) => String -> m a
2015-08-14 03:57:33 +00:00
exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
fatalError :: String -> a
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
catchArgs :: (Monad m, ExceptionMonad m) => String -> m a -> m a
catchArgs cmd action =
action `gcatch` \(PatternMatchFail _) ->
throw $ InvalidCommandLine (Left cmd)
2015-08-10 08:10:33 +00:00
nukeCaches :: IOish m => GhcModT m ()
nukeCaches = do
chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"
c <- cradle
when (isCabalHelperProject $ cradleProject c) $ do
2015-08-10 08:10:33 +00:00
let root = cradleRootDir c
2015-08-18 12:55:45 +00:00
let dist = cradleDistDir c
liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> dist]
2015-08-10 08:10:33 +00:00
trySome :: IO a -> IO (Either SomeException a)
trySome = try