-----------------------------------------------------------------------------
-- |
-- Module      :  XMonadContrib.GhcPrompt
-- Copyright   :  (C) 2007 Andrea Rossato
-- License     :  BSD3
-- 
-- Maintainer  :  andrea.rossato@unibz.it
-- Stability   :  unstable
-- Portability :  unportable
--
-- A ssh prompt for XMonad
--
-----------------------------------------------------------------------------

module XMonadContrib.GhcPrompt (
                             -- * Usage
                             -- $usage
                             ghcPrompt
                              ) where

import Data.List

import XMonad
import XMonadContrib.XPrompt

import Control.Concurrent
import Control.Exception
import System.Process
import System.IO
import System.Exit

-- $usage
-- 1. In Config.hs add:
--
-- > import XMonadContrib.XPrompt
-- > import XMonadContrib.GhcPrompt
--
-- 2. In your keybindings add something like:
--
-- >   , ((modMask .|. controlMask, xK_h), ghcPrompt defaultXPConfig)
--
-- You also need the utility commented out at the end of this file.

data Ghc = Ghc

instance XPrompt Ghc where
    showXPrompt Ghc = "Eval:   "
                     
ghcPrompt :: XPConfig -> X ()
ghcPrompt c = do
  mkXPrompt Ghc c (mkComplFunFromList []) (ghc c [])

type Expr = String

ghc :: XPConfig -> [Expr] -> String -> X ()
ghc conf exps s 
    | s == ":quit" || s == ":q" || s == [] = return ()
    | otherwise = do
  let exps' = exps ++ [s]
      run = "heval \'" ++ show exps' ++ "\'"
  (i,o,e,p) <- io $ runInteractiveCommand $ run
  exit <- io $ waitForProcess p
  case exit of
    ExitSuccess -> do
              err <- io $ hGetContents e
              out <- io $ hGetContents o
              -- get err and out
              oMVar <- io $ newEmptyMVar
              eMVar <- io $ newEmptyMVar
              io $ forkIO $ evaluate (length out) >> putMVar oMVar ()
              io $ forkIO $ evaluate (length err) >> putMVar eMVar ()
              -- wait
              io $ takeMVar oMVar
              io $ takeMVar eMVar
              let res = if out == [] then err else out
              io $ mapM_ hClose [i,o,e]
              mkXPrompt Ghc conf (\_ -> return $ lines res) (ghc conf exps')
    _ -> do io $ mapM_ hClose [i,o,e]
            mkXPrompt Ghc conf (mkComplFunFromList []) (ghc conf exps') 
            
{-

You need this in you path: save it as Heval.hs, but first EDIT ghcPath
to fit your system!!

Then compile with
ghc --make Heval.hs -o heval -package ghc


--------------------- file starts here --------------------
module Main where

import GHC
import DynFlags
import PackageConfig
import System.Environment

import Data.Dynamic
import Data.List
import Data.Maybe



ghcPath :: String
ghcPath = "/usr/lib/ghc-6.6.1"

main :: IO ()
main = defaultErrorHandler defaultDynFlags $ do
  args <- getArgs
  let exps = case args of
               [] -> []
               x -> read (x !! 0) :: [String]
  session <- newSession Interactive (Just ghcPath)
  setSessionDynFlags session =<< getSessionDynFlags session
  setContext session [] [mkModule (stringToPackageId "base") (mkModuleName "Prelude")]
  case exps of
    [] -> return ()
    x -> do updateSession session x
            runExp session $ last x

updateSession :: Session ->  [String] ->  IO ()
updateSession ses l =
    mapM_ (runStmt ses) l

runExp :: Session -> String -> IO ()
runExp ses s
    -- "let: " update session
    | "let " `isPrefixOf` s = do
  runStmt ses s
  return ()
    -- something to eval
    | otherwise = do
  res <- catch (dynCompileExpr ses ("show $ "++ s)) (\e -> return $ Just $ toDyn $ show e)
  case res of
    Just x -> do 
        let res' = fromDynamic x :: Maybe String
        putStrLn (fromMaybe "" res')
    _ -> return ()

-}