GhcProcess.hs

{- This module was inspired by:

http://haskell.org/sitewiki/images/5/51/Interactive.hs and
http://haskell.org/haskellwiki/GHC/As_a_library

-}

module GhcProcess where

import qualified Protocol as P
import qualified Options as Opt

import qualified GHC as GHC
import qualified Outputable as GHC
import qualified PackageConfig as GHC
import qualified DynFlags as GHC
import qualified Panic as GHC
import qualified Distribution.InstalledPackageInfo as GHC
import qualified UniqFM as GHC

import Control.Concurrent
import Control.Concurrent.Chan
import Network
import System.IO
import System
import Monad (when)
import System.Time

-- import qualified Packages as GHC
-- import qualified ErrUtils as GHC

-- Should'n we do: main = defaultErrorHandler defaultDynFlags $ do

main :: IO()
main = do clearLog
          withSocketsDo startSession
              `catch` (\e -> do myLog (show e)
                                return ()
                      )

startSession :: IO ()
startSession =
    do request <- getArgs
       (ghcPath, outPort, inPort) <- readIO $ head request
       --
       session <- initializeSession ghcPath
       logPkgDB session
       --
       myLog ("Read port numbers: " ++ show (outPort, inPort))
       inHandle  <- connectTo "localhost" (PortNumber $ fromInteger inPort)
       myLog ("Connected to inPort")
       outHandle <- connectTo "localhost" (PortNumber $ fromInteger outPort)
       myLog ("Connected to outPort")
       P.setIsExecuting outHandle False
       f <- hGetContents inHandle
       let reply :: (Show s) => s -> IO()
           reply s = do hPutStrLn inHandle $ show s
                        hFlush inHandle
       insertIO <- channeledIO outHandle
       myLog ("Ready to recieve commands")
       mapM_ (execCommand session insertIO reply) $ lines f
       return ()


myLog :: String -> IO ()
myLog msg = appendFile "log" (msg ++ "\n")

clearLog :: IO ()
clearLog = do t <- getClockTime
              writeFile "log" ("Initiating log at " ++ (show t) ++ "\n")

putError :: String -> IO ()
putError msg = hPutStr stderr msg

putMsg :: String -> IO ()
putMsg msg = putStr msg

execCommand :: GHC.Session
            -> (IO () -> IO t)
            -> (Opt.Options -> IO ())
            -> String
            -> IO ()
execCommand session insertIO reply cmd =
    do cmd' <- readIO cmd
       case cmd' of
         P.Exec stmt -> do myLog $ show stmt ++ " ... "
                           insertIO $ evalStmt session stmt
                           myLog $ "finished.\n"
         P.Kill -> do threads <- readMVar GHC.interruptTargetThread
                      hPutStrLn stderr ("Debug output. Threads: " ++ show threads)
                      killThread $ head threads
         P.GetOptions -> do dynFlags <- GHC.getSessionDynFlags session
                            reply $ Opt.ghcflagsToOptions dynFlags
         P.SetOptions userFlags ->
             do dynFlags <- GHC.getSessionDynFlags session
                userFlags' <- readIO userFlags
                GHC.setSessionDynFlags session $ Opt.setOptions userFlags' dynFlags
                return ()
                
evalStmt :: GHC.Session -> String -> IO ()
evalStmt session stmt | take 4 stmt == ":set"
                          = do dynFlags <- GHC.getSessionDynFlags session
                               (newFlags, unknownArgs) <- GHC.parseDynamicFlags dynFlags (words $ drop 4 stmt)
                               GHC.setSessionDynFlags session newFlags
                               hPutStrLn stderr $ "Unrecognized flags: " ++ unlines unknownArgs
                               hFlush stderr
                      | otherwise = execStmt session stmt

execStmt :: GHC.Session -> String -> IO ()
execStmt session stmt =
    do result <- GHC.runStmt session stmt GHC.RunToCompletion
       GHC.runStmt session "hFlush stdout >> hFlush stderr" GHC.RunToCompletion
       case result of
	 GHC.RunOk names    -> putMsg   ("*** Ok: " ++ showNames names ++ "\n")
         GHC.RunFailed      -> putError "*** Failed\n"
         GHC.RunException e -> putError ("*** Exception: " ++ (show e) ++ "\n")
       hFlush stdout >> hFlush stderr


channeledIO :: Handle -> IO (IO t -> IO ())
channeledIO outHandle =
    do ioChan <- newChan
       let readAndExec = do isEmpty <- isEmptyChan ioChan
                            when isEmpty (P.setIsExecuting outHandle False)
                            ioAction <- readChan ioChan
                            P.setIsExecuting outHandle True
                            ioAction
                            readAndExec
           insertIO io' = do writeChan ioChan io'
       forkIO $ readAndExec
       return insertIO

-- If GHC.runStmt returns GHC.RunOk names then names is a list
-- of the names of all variables that were bound during evaluation.
-- This function somehow manages to pretty-print such a list.
showNames :: [GHC.Name] -> String
showNames = GHC.showSDoc . GHC.ppr

logPkgDB :: GHC.Session -> IO ()
logPkgDB session =
    do flags <- GHC.getSessionDynFlags session
       let pkgName pkg = "Package: " ++ (GHC.pkgName $ GHC.package pkg) ++ "\n" ++
                         "Copyright: " ++ GHC.copyright pkg ++ "\n" ++
                         "Haddock HTML: " ++ (show $ GHC.haddockHTMLs pkg)
           handleUniqFM uniqFM = do myLog $ "Number of elements" ++ show (length $ GHC.ufmToList uniqFM)
                                    mapM_ (myLog . pkgName) $ GHC.eltsUFM uniqFM
       maybe (myLog "Pkg DB: Nothing") handleUniqFM (GHC.pkgDatabase flags)

initializeSession :: String -> IO GHC.Session
initializeSession ghcPath =
    do session <- GHC.newSession (Just ghcPath)
       
       dynFlags <- GHC.getSessionDynFlags session
       GHC.setSessionDynFlags session dynFlags{GHC.hscTarget=GHC.HscInterpreted}
       
       prelude  <- GHC.findModule session (GHC.mkModuleName "Prelude") Nothing
       systemIO <- GHC.findModule session (GHC.mkModuleName "System.IO") Nothing
       GHC.setContext session [] [ prelude, systemIO ]
       
       return session

{- GHC.log_action logs error messages from compilation failure:
       let myLogAction _ locSpec style errMsg = hPutStrLn stderr ("Checkpoint charlie: " ++ showMsg) where
               showMsg = GHC.showSDoc $ GHC.withPprStyle style $ GHC.mkLocMessage locSpec errMsg
           dflags1 = dflags0 { GHC.log_action = myLogAction }
-}
{-
       -- Loading modules:
       -- 1) For example loading MyPrelude.hs
       target <- GHC.guessTarget "MyPrelude.hs" Nothing
       GHC.addTarget session target
       -- this would unload the standard prelude if it had already been loaded
       GHC.load session GHC.LoadAllTargets
       
       -- 2) We need to load the standard prelude (I think), because of
       -- "GHC.load seesion..." unloaded the prelude.
       let preludeModule  = GHC.mkModule (GHC.stringToPackageId "base") (GHC.mkModuleName "Prelude")
       systemIOModule <- GHC.findModule session (GHC.mkModuleName "System.IO") Nothing
       GHC.setContext session [] [preludeModule, systemIOModule]
-}