286 lines
9.8 KiB
Haskell
286 lines
9.8 KiB
Haskell
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
|
|
|
|
module Main where
|
|
|
|
import Control.Category
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Data.Typeable (Typeable)
|
|
import Data.List
|
|
import Data.List.Split
|
|
import Data.Char (isSpace)
|
|
import Data.Maybe
|
|
import Exception
|
|
import Language.Haskell.GhcMod
|
|
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
|
|
import Language.Haskell.GhcMod.Types
|
|
import Language.Haskell.GhcMod.Monad
|
|
import System.FilePath ((</>))
|
|
import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
|
|
removeDirectoryRecursive)
|
|
-- import System.Environment (getArgs)
|
|
import System.IO
|
|
import System.Exit
|
|
import Text.PrettyPrint hiding ((<>))
|
|
import Prelude hiding ((.))
|
|
import GHCMod.Options
|
|
|
|
import Misc
|
|
|
|
ghcModStyle :: Style
|
|
ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
|
|
|
|
----------------------------------------------------------------
|
|
|
|
{-
|
|
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.
|
|
`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
|
|
-}
|
|
|
|
----------------------------------------------------------------
|
|
|
|
data CmdError = UnknownCommand String
|
|
| NoSuchFileError String
|
|
| LibraryError GhcModError
|
|
|
|
deriving (Show, Typeable)
|
|
|
|
instance Exception CmdError
|
|
|
|
data InteractiveOptions = InteractiveOptions {
|
|
ghcModExtensions :: Bool
|
|
}
|
|
|
|
handler :: IOish m => GhcModT m a -> GhcModT m a
|
|
handler = flip gcatches $
|
|
[ GHandler $ \(FatalError msg) -> exitError msg
|
|
, GHandler $ \e@(ExitSuccess) -> throw e
|
|
, GHandler $ \e@(ExitFailure _) -> throw e
|
|
, GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e
|
|
]
|
|
|
|
main :: IO ()
|
|
main = do
|
|
hSetEncoding stdout utf8
|
|
parseArgs >>= \res@(globalOptions, _) ->
|
|
catches (progMain res) [
|
|
Handler $ \(e :: GhcModError) ->
|
|
runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
|
|
]
|
|
|
|
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
|
|
"check" -> checkSyntax [arg]
|
|
"find" -> do
|
|
db <- getDb symdbreq >>= checkDb symdbreq
|
|
lookupSymbol arg db
|
|
|
|
"info" -> info (head args) $ Expression $ concat $ tail args'
|
|
"type" -> locArgs types args
|
|
"split" -> locArgs splits args
|
|
|
|
"sig" -> locArgs sig args
|
|
"auto" -> locArgs auto args
|
|
"refine" -> locArgs' refine args
|
|
|
|
"boot" -> boot
|
|
|
|
"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
|
|
interactiveHandlers =
|
|
[ GHandler $ \e@(FatalError _) -> throw e
|
|
, GHandler $ \e@(ExitSuccess) -> throw e
|
|
, GHandler $ \e@(ExitFailure _) -> throw e
|
|
, GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return ""
|
|
]
|
|
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
|
|
|
|
getFileSourceFromStdin :: IO String
|
|
getFileSourceFromStdin = do
|
|
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* :'(
|
|
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
|
|
|
|
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
|
|
|
|
|
|
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
|
|
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)
|
|
|
|
nukeCaches :: IOish m => GhcModT m ()
|
|
nukeCaches = do
|
|
chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"
|
|
c <- cradle
|
|
|
|
when (isCabalHelperProject $ cradleProject c) $ do
|
|
let root = cradleRootDir c
|
|
let dist = cradleDistDir c
|
|
liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> dist]
|
|
|
|
trySome :: IO a -> IO (Either SomeException a)
|
|
trySome = try
|