ghc-mod/src/GHCMod.hs

{-# 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