Implement check of bidirectionalizability.
[darcs-mirror-sem_syn.git] / MyInterpret.hs
index e9cb977..16c6ed6 100644 (file)
@@ -8,7 +8,7 @@ module MyInterpret
          where 
 
 import Language.Haskell.Interpreter
-import Language.Haskell.Interpreter.GHC.Unsafe
+import Language.Haskell.Interpreter.Unsafe
 
 import Prelude hiding (catch)
 import Control.Concurrent
@@ -22,25 +22,20 @@ import Data.Either
 
 
 -- Scoped modules
-modules = [    "Data.Bff",
-              "SimpleTree",
-               "Prelude",
+defaultModules = [    "Prelude",
                "Data.List"
---               "ShowQ",
---               "ShowFun",
---               "SimpleReflect",
---               "Data.Function",
         ]
 
-data MyException = MyException String deriving (Typeable)
+data MyException = MyException String deriving (Show,Typeable)
+instance Exception MyException
 
 timeoutIO action = bracket
        (do mainId <- myThreadId
-           installHandler sigXCPU (CatchOnce $ throwDynTo mainId $ MyException "Time limit exceeded.") Nothing
+           installHandler sigXCPU (CatchOnce $ throwTo mainId $ MyException "Time limit exceeded.") Nothing
            forkIO $ do
                    threadDelay (5 * 1000 * 1000)
                    -- Time's up. It's a good day to die.
-                   throwDynTo mainId (MyException "Time limit exceeded")
+                   throwTo mainId (MyException "Time limit exceeded")
 
                    {- why do we need that here?
  -                 yield -- give the other thread a chance
@@ -56,37 +51,49 @@ timeoutIO action = bracket
                mainId <- myThreadId
                mvar <- newEmptyMVar
                forkIO $ (action >>= putMVar mvar) `catch`
-                        (throwTo mainId)      
+                        (\e -> throwTo mainId (e::SomeException))
                ret <- takeMVar mvar
                evaluate (length ret) -- make sure exceptions are handled here
                return ret
        )
 
--- myInterpreter :: String -> IO String
-myInterpreter todo exp = timeoutIO $ do
-        when (unsafe exp) $ throwDyn (MyException "Indicators for unsafe computations found in exp")
+myInterpreter :: [String] -> [String] -> (String -> InterpreterT IO [a]) -> String -> IO [a]
+myInterpreter mods imports todo exp = timeoutIO $ do
+        when (unsafe exp) $ throw (MyException "Indicators for unsafe computations found in exp")
 
        eResult <- runInterpreter $ do
-                setUseLanguageExtensions False
+                set [languageExtensions := []]
                -- Not available in hint-3.2?
                 -- setOptimizations All
 
                 reset
-                -- no need for temporary files I hope
-                setInstalledModsAreInScopeQualified True 
+
+                if null mods
+                  then do -- no need for temporary files I hope. Used by bff
+                       set [installedModulesInScope := True ]
+                       setImports defaultModules
+                  else do -- Only these modules in scope. No Prelude either!
+                       loadModules mods
+                       set [installedModulesInScope := False ]
+                       setImports imports
        
                unsafeSetGhcOption "-fno-monomorphism-restriction"
+                unsafeSetGhcOption "-fno-warn-warnings-deprecations"
                 
-                setImports modules
+               --liftIO $ putStrLn exp --this makes it impossible to run at www-ps.uni-bonn.de
+                ret <- todo exp
+
+                -- Hopefully removes temporary files
+                reset
                 
-               liftIO $ putStrLn exp
-                todo exp
+                return ret
        
        case eResult of
                Left exception -> throw exception
                Right result -> return result
         
-formatInterpreterError (UnknownError s) = "Unknown Interpreter Error " ++ s
+formatInterpreterError :: InterpreterError -> [Char]
+formatInterpreterError (UnknownError s) = "Unknown Interpreter Error:\n" ++ s
 formatInterpreterError (WontCompile es) = "Could not compile code:\n" ++ unlines (map errMsg es)
 formatInterpreterError (NotAllowed s) = "Not allowed here " ++ s
 formatInterpreterError (GhcException e) = "GHC Exception"
@@ -109,21 +116,21 @@ unsafeNames = ["unsafe", "inlinePerform", "liftIO", "Coerce", "Foreign",
 
 catchInterpreterErrors :: IO a -> IO (Either String a)
 catchInterpreterErrors action = 
-        flip catchDyn (return . Left . formatInterpreterError) $
-        flip catchDyn (\(MyException s) -> return (Left s))   $
-       handleJust errorCalls (return . Left)                  $ -- bff in Bff.hs uses these
+        flip catch (return . Left . formatInterpreterError) $
+        flip catch (\(MyException s) -> return (Left s))   $
+        flip catch (\(ErrorCall s) -> return (Left s))   $
         Right `fmap` action
 
-simpleInterpret :: String -> String -> IO String 
-simpleInterpret defs what = 
-       myInterpreter eval $
+simpleInterpret :: [String] -> [String] -> String -> String -> IO String 
+simpleInterpret mods imports defs what = 
+       myInterpreter mods imports eval $
           "let \n" ++
            unlines (map (replicate 12 ' '++) (lines defs)) ++ 
             replicate 8 ' ' ++ "in " ++ what
 
-simpleTypeOf :: String -> String -> IO String 
-simpleTypeOf defs what = 
-       myInterpreter typeOf $
+simpleTypeOf :: [String] -> [String] -> String -> String -> IO String 
+simpleTypeOf mods imports defs what = 
+       myInterpreter mods imports typeOf $
           "let \n" ++
            unlines (map (replicate 12 ' '++) (lines defs)) ++ 
             replicate 8 ' ' ++ "in " ++ what