activehs-0.3.1: Special.hs

{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, PatternGuards, NamedFieldPuns #-}

module Special
    ( SpecialTask (..), exerciseServer'
    ) where

import Smart
import QuickCheck
import Result
import Lang
import Logger
import Html
import Qualify (qualify)
import Hash

import ActiveHs.Base (WrapData2)

import qualified Data.Text as T
import qualified Data.Text.IO as T

import Control.DeepSeq
import Control.Concurrent.MVar
import Control.Exception
import System.FilePath ((</>),takeFileName)
import System.Directory (getTemporaryDirectory)

import Control.Concurrent (threadDelay, forkIO, killThread)
--import Prelude hiding (catch)


---------------------------------------------------------------

timeout :: forall b. Int -> IO b -> IO b -> IO b
timeout delay error action = do
    v <- newEmptyMVar 
    t1 <- forkIO $ threadDelay delay >> error >>= putMVar v
    t2 <- forkIO $ action >>= putMVar v
    x <- takeMVar v
    killThread t1
    killThread t2
    return x

----------------------------

data SpecialTask
    = Eval
    | Compare String String
    | Compare2 T.Text [String] String
    | Check String [FilePath] T.Text [String] [([String],String)] String String

exerciseServer' 
    :: String
    -> TaskChan
    -> Bool
    -> FilePath
    -> T.Text
    -> Language
    -> Hash
    -> SpecialTask
    -> IO [Result]

exerciseServer' qualifier ch verbose fn sol lang m5 task = do

    let error = do
            logStrMsg 0 (logger ch) $ "Server error:" ++ show m5
            return [Error True "Server error."]

        action =
                 do res <- eval task
                    res `deepseq` return res
           `catch` \(e :: SomeException) ->             -- ???
                  return [Error True $ show e]

    timeout (10*1000000) error action

  where

    eval Eval
        = interp verbose m5 lang ch fn (T.unpack sol) $ \a -> return $ return []

    eval (Compare hiddenname goodsol)
        = interp verbose m5 lang ch fn (T.unpack sol) $ \a ->
            do  x <- interpret (wrap2 a hiddenname) (as :: WrapData2)
                return $ compareMistGen lang (show m5) x $ goodsol

    eval (Compare2 env funnames s) = do
        fn' <- tmpSaveHs "hs" (show m5) $ env `T.append` sol
        case qualify qualifier funnames s of
            Left err -> return [Error True err]
            Right s2 -> interp verbose m5 lang ch fn' s $ \a ->
                fmap (compareClearGen lang (show m5)) $ interpret (wrap2 a s2) (as :: WrapData2)

    eval (Check ext sourcedirs env funnames is i j) = do
        fn' <- tmpSaveHs ext (show m5) $ env `T.append` sol
        case ext of
            "hs" -> do
                ss <- quickCheck qualifier m5 lang ch fn' (T.unpack sol) funnames is
                let ht = head $ [x | ModifyCommandLine x <- ss] ++ [""]
                return [ShowInterpreter lang 59 (getTwo "eval2" (takeFileName fn) j i j) j 'E' ht ss]

tmpSaveHs :: String -> String -> T.Text -> IO FilePath
tmpSaveHs ext x s = do
    tmpdir <- getTemporaryDirectory
    let name = "GHCiServer_" ++ x
        tmp = tmpdir </> name ++ "." ++ ext
    T.writeFile tmp $ case ext of
        "hs" -> s
    return tmp