{-# 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] "lint" -> lint defaultLintOpts 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 "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 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