Repl.hs

-- c-repl: a C read-eval-print loop.
-- Copyright (C) 2008 Evan Martin <martine@danga.com>

-- The main function and REPL handling.

import Prelude hiding (log)
import Control.Exception
import Control.Monad
import Control.Monad.Error
import Data.List (find, isPrefixOf, intercalate, stripPrefix)
import Data.Maybe (catMaybes, mapMaybe)
import qualified System.Console.Readline as Readline
import System.Environment
import System.Exit
import System.IO
import System.Posix.Types (ProcessID)
import System.Process
import System.FilePath
import System.Directory

import qualified Child
import qualified CodeSnippet
import CodeSnippet (CodeSnippet)
import qualified GCCXML
import qualified GDBMI

log :: Show a => String -> a -> IO ()
log desc obj = putStrLn (desc ++ " " ++ show obj)

data InterpEnv = InterpEnv {
  envVerbose :: Bool,         -- Verbose flag.
  envChild   :: Child.Child,  -- Child process that executes code.
  envHeaders :: [String],     -- Headers to #include, like "<stdio.h>".
  envLibraries :: [String],   -- Libraries to link in, like "foo" in -l"foo".
  envSyms    :: [(String, GCCXML.Symbol)],  -- Imported header symbols.
  envDecls   :: [String],     -- Declared variables.
  envEntry   :: Int           -- Current .so number we're on.
}
instance Show InterpEnv where
  show env = "headers: " ++ show (envHeaders env)
          ++ " decls: " ++ show (envDecls env)
          ++ " entry: " ++ show (envEntry env)

creplDir = ".c-repl"
cleanupDir :: IO ()
cleanupDir = do
  exists <- doesDirectoryExist creplDir
  when exists $ do
    files <- getDirectoryContents creplDir
    sequence_ [removeFile (creplDir </> x) | x <- files, x /= "." && x /= ".."]
    removeDirectory creplDir

setupDir = do
  cleanupDir
  createDirectory creplDir

includesAsSource :: [String] -> String
includesAsSource = concatMap (\h -> "#include " ++ h ++ "\n")

makeSnippet :: InterpEnv -> String -> Int -> Either String (InterpEnv, String)
makeSnippet env code entry = do
  snippet <- CodeSnippet.parse code
  let source = snippetToSource env snippet entry
  let decl = snippetToDecl snippet
  return (env {envDecls=envDecls env ++ catMaybes [decl]},
          source)

snippetToDecl :: CodeSnippet -> Maybe String
snippetToDecl (CodeSnippet.Code _)         = Nothing
snippetToDecl (CodeSnippet.VarDecl decl _) = return decl
snippetToDecl (CodeSnippet.FunDecl decl _) = return decl

snippetToSource :: InterpEnv -> CodeSnippet -> Int -> String
snippetToSource env snippet entry =
  intercalate "\n" [incl, decls, line, global snippet,
                    func, line, local snippet, "}\n"]
  where
  incl = includesAsSource (envHeaders env)
  decls = concatMap (++ ";\n") (envDecls env)
  line = "#line 1"  -- So gcc error messages have user-understandable lineno.
  global (CodeSnippet.Code _) = ""
  global (CodeSnippet.VarDecl decl _) = decl ++ ";"
  global (CodeSnippet.FunDecl decl code) = decl ++ code ++ ";"
  func = "void dl" ++ show entry ++ "() {"
  local (CodeSnippet.Code str) = str ++ ";"
  local (CodeSnippet.VarDecl _ str) = str ++ ";"
  local (CodeSnippet.FunDecl _ _ ) = ""

generateSharedObject :: InterpEnv -> String -> IO (Either String ())
generateSharedObject env snippet = do
  let libs = concatMap (\lib -> "-l" ++ lib ++ " ") (envLibraries env)
  let soname = creplDir </> "dl" ++ show (envEntry env) ++ ".so"
  let cmd = "gcc -Wall " ++ libs ++ "-xc -g -shared -fPIC -o " ++ soname ++ " -"
  (inp,out,err,pid) <- runInteractiveCommand cmd 
  error <- hGetContents err
  hPutStr inp snippet
  hClose inp
  exit <- waitForProcess pid
  when (not (null error)) $ putStr error
  case exit of
    ExitSuccess -> return (return ())
    ExitFailure code -> return (throwError "compile failed.")

-- c-repl meta-level parse of a line.
data Command = IncludeHeader String
             | Code String
             | TypeQuery String
             | InfoQuery String
             | LoadLibrary String
             | HelpQuery

metacommands :: [(String, String, String -> Command)]
metacommands = [
  ("t", "print the type of a symbol",    TypeQuery),
  ("p", "print the value of a variable", InfoQuery),
  ("i", "#include a header",             IncludeHeader),
  ("l", "load a library",                LoadLibrary)
  ]

parseLine :: String -> Either String Command
parseLine line | inc `isPrefixOf` line =
  let Just h = stripPrefix inc line in return $ IncludeHeader h
  where inc = "#include "
parseLine ('.':line) =
  let (cmd, rest) = breakApart (==' ') line in
  case find (\(key,_,_) -> key `isPrefixOf` cmd) allcommands of
    Just (_, _, command) -> return (command rest)
    Nothing -> throwError "unknown command"
  where
  allcommands = ("h", "", const HelpQuery) : metacommands
  breakApart pred l =
    let (a,b) = break pred l in
    case b of [] -> (a, b); _ -> (a, tail b)
parseLine line = return $ Code line

runLine :: InterpEnv -> String -> IO (Either String InterpEnv)
runLine env line = runErrorT $ do
  cmd <- ErrorT $ return $ parseLine line
  case cmd of
    IncludeHeader header -> do
      let env' = env {envHeaders=envHeaders env ++ [header]}
      updateCompletionSymbols env'
    Code code -> do
      let entry = envEntry env
      (env', code) <- ErrorT $ return (makeSnippet env line entry)
      runCode env' code
    TypeQuery var -> do
      liftIO $ case lookup var (envSyms env) of
        Nothing -> putStrLn "unknown"
        Just sym -> putStrLn $ GCCXML.showSymbol sym
      return env
    LoadLibrary lib -> do
      return $ env {envLibraries=envLibraries env ++ [lib]}
    InfoQuery var -> do
      let pid = fromIntegral (Child.childPid (envChild env))
      let cmd = GDBMI.MICommand ("var-create v * " ++ var)
      GDBMI.MIOutput log out <- ErrorT $ runGDB pid cmd
      case out of
        Nothing -> throwError $ "GDB unexpected output " ++ show log
        Just (GDBMI.MIError e) -> throwError $ "GDB error: " ++ show e
        Just (GDBMI.MIDone args) -> do
          vals <- return $ mapM (`lookup` args) ["type", "value"]
          case vals of
            Just [GDBMI.MIString typ, GDBMI.MIString val] ->
              liftIO $ putStrLn $ typ ++ ": " ++ val
            _ -> throwError $ "bad output args: " ++ show args
      return env
    HelpQuery -> do
      liftIO $ do
        putStrLn "you can enter:"
        putStrLn "- snippets of code: e.g. int x = 3 or printf(\"hi\\n\")"
        putStrLn "- includes: e.g. #include <foobar.h>"
        putStrLn "- or a metacommand of the form '.command args'"
        putStrLn "metacommands are:"
        forM_ metacommands $ \(key, desc, _) ->
          putStrLn $ "- " ++ key ++ ": " ++ desc
      return env
  where
  runCode :: InterpEnv -> String -> ErrorT String IO InterpEnv
  runCode env code = do
    let entry = envEntry env
    liftIO $ when (envVerbose env) $ putStrLn code
    ErrorT $ generateSharedObject env code
    runok <- liftIO $ Child.run (envChild env) entry
    case runok of
      Left err -> do
        -- Run failed.  Reboot the child.
        liftIO $ putStrLn err
        child <- ErrorT Child.start
        return $ env {envChild=child, envEntry=1}
      Right ok -> return $ env {envEntry = envEntry env + 1}

runGDB :: ProcessID -> GDBMI.GDBCommand -> IO (Either String GDBMI.MIOutput)
runGDB pid cmd = bracket before after todo where
  before = GDBMI.attach Nothing pid
  after :: Either String (GDBMI.GDB, GDBMI.MIOutput) -> IO ()
  after (Right (gdb, log)) = GDBMI.detach gdb
  after _                  = return ()
  todo (Right (gdb, log)) = GDBMI.runCommand cmd gdb
  todo (Left err)         = return $ throwError err

updateCompletionSymbols :: InterpEnv -> ErrorT String IO InterpEnv
updateCompletionSymbols env = do
  let code = includesAsSource (envHeaders env)
  symbols <- ErrorT $ GCCXML.symbols code
  let newsyms = mapMaybe (\sym -> do name <- symbolName sym; return (name, sym))
                         symbols
  let names = map fst newsyms
  when (envVerbose env) $ liftIO $ print names
  liftIO $ Readline.setCompletionEntryFunction (Just (complete names))
  return $ env {envSyms=envSyms env ++ newsyms}
  where
  complete names input = return $ filter (input `isPrefixOf`) names
  symbolName (GCCXML.Function name args) = return name
  symbolName (GCCXML.Type _) = Nothing

main = do
  args <- getArgs
  let verbose = case args of
                  "-v":_ -> True
                  _ -> False
  putStrLn "c-repl: a C read-eval-print loop."
  putStrLn "enter '.h' at the prompt for help."
  -- Turn off the space after tab-completion.
  Readline.setCompletionAppendCharacter (Just '\0')
  bracket_ setupDir cleanupDir $ do
    env <- runErrorT $ do
      child <- ErrorT Child.start
      let env = InterpEnv {
        envVerbose=verbose, envChild=child,
        envHeaders=["<stdio.h>", "<math.h>"], envLibraries=["m"],
        envSyms=[], envDecls=[],
        envEntry=1}
      updateCompletionSymbols env
    case env of
      Left error -> putStrLn $ "error: " ++ error
      Right env ->
        loop env `finally` (Child.stop (envChild env))
    where
    loop env = do
      line <- Readline.readline "> "
      case line of
        Nothing   -> putStrLn "" >> return ()  -- EOF; time to die.
        Just line -> do
          Readline.addHistory line
          env' <- runLine env line
          case env' of
            Left err -> do putStrLn err; loop env
            Right env' -> loop env'