-----------------------------------------------------------------------------
-- |
-- Module      :  Heval
-- Copyright   :  (c) Andrea Rossato
-- License     :  BSD3
--
-- Maintainer  :  Andrea Rossato <andrea.rossato@unibz.it>
-- Stability   :  unstable
-- Portability :  unportable
--
--  A simple evaluator used by a XMonad prompt
--
-----------------------------------------------------------------------------

module Main where

import GHC
import Panic
import DynFlags
import PackageConfig
import ErrUtils
import SrcLoc  (SrcSpan)
import Outputable

import Control.Concurrent
import Control.Exception
import Data.Char
import Data.Dynamic
import Data.List
import Data.Maybe
import Prelude hiding (catch)
import System.Exit
import System.IO
import System.Random
import System.Posix.Resource
import System.Posix.Signals

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

myLog :: Severity -> SrcSpan -> PprStyle -> Message -> IO ()
myLog = \severity _ style msg ->
             case severity of
               SevInfo  -> hPutStrLn stdout (show (msg style))
               SevFatal -> hPutStrLn stdout (show (msg style))
               _        -> hPutStrLn stdout (show (msg style))

rlimit :: ResourceLimit
rlimit = ResourceLimit 5

main :: IO ()
main = do
  setResourceLimit ResourceCPUTime (ResourceLimits rlimit rlimit)
  defaultErrorHandler defaultDynFlags $ do
         s <- getLine
         let exps = read s :: [String]
         ses <- initSession
         case exps of
           []     -> return ()
           (x:[]) -> runExp ses x
           xs      -> do updateSession ses (init xs)
                         runExp ses (last xs)

initSession :: IO Session
initSession = do
  ses <- newSession (Just ghcPath)
  df <- getSessionDynFlags ses
  setSessionDynFlags ses df  {log_action = myLog }
  setContext ses [] [mkModule (stringToPackageId "base") (mkModuleName "Prelude")]
  return ses

updateSession :: Session ->  [String] ->  IO ()
updateSession ses l =
    mapM_ (runWithTimeOut 3 . flip (runStmt ses) SingleStep) l

exprToRun :: String -> IO String
exprToRun expr = do
  x <- sequence (take 3 (repeat $ getStdRandom (randomR (97,122)) >>= return . chr))
  return ("let { "++ x ++
          " = " ++ expr ++
          "\n} in take 2048 (show " ++ x ++
          ")")

runWithTimeOut :: Int -> IO a -> IO a
runWithTimeOut to action = do
  t <- forkIO $ checkerThread
  res <- action
  killThread t
  return res
  where
    -- if this thread is not killed within t seconds it will raise the
    -- equivalent of a ^C
    checkerThread = do
      threadDelay (to * 1000000)
      -- FIXME
      hPutStrLn stdout "Interrupted."
      raiseSignal sigQUIT

runExp :: Session -> String -> IO ()
runExp ses (':':com) =
    specialCommand ses com
runExp ses s
    -- nothing: restart
    | s == "" || s == "\r" || s == "\n" = do
  return ()
     -- let: bind and update session
    | "let " `isPrefixOf` s = do
  runWithTimeOut 3 $ runStmt ses s SingleStep
  return ()
    -- something to eval
    | otherwise = do
  expr <- exprToRun s
  catch (go expr) (\e -> hPutStrLn stdout $ showException e)
    where
      go e = do
        str <- evalExpr ses e
        putStrLn str

evalExpr :: Session -> String -> IO String
evalExpr ses expr = do
  maybe_dyn <- dynCompileExpr ses expr
  case maybe_dyn of
    Just dyn -> return $ (fromMaybe "" (fromDynamic dyn :: Maybe String))
    _ -> do return []

-- special commands
specialCommand :: Session -> String -> IO ()
specialCommand _ com
    -- stop: stop server
    | "stop" `isPrefixOf` com = exitWith ExitSuccess
    -- quit: exit
    | "quit" `isPrefixOf` com = return ()
    | otherwise = return ()