[Xmonad] a safer ghci prompt

[Andrea Rossato]

Hi,

attached you'll find a safer ghci prompt, that uses an external
program to evaluate haskell expression.

This is still work in progress, but you can have an idea of what I'd
like to do.

Feedback highly appreciated!

ciao
andrea

ps: to use:

1. save the attached file as GhcPrompt.hs and follow the install
   instruction;

2. save and compile the uitlity you'll find at the end of the file.

3. enjoy.
-------------- next part --------------
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonadContrib.GhcPrompt
-- Copyright   :  (C) 2007 Andrea Rossato
-- License     :  BSD3
-- 
-- Maintainer  :  andrea.rossato at 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 ()

-}