Combined-line mode checks bidirectionalizability
[darcs-mirror-sem_syn.git] / MyInterpret.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2
3 module MyInterpret
4         ( simpleInterpret
5         , simpleTypeOf
6         , catchInterpreterErrors
7         )
8          where 
9
10 import Language.Haskell.Interpreter
11 import Language.Haskell.Interpreter.Unsafe
12
13 import Prelude hiding (catch)
14 import Control.Concurrent
15 import Control.Exception
16 import Control.Monad
17 import Control.Monad.Error
18 import System.Posix.Signals
19 import Data.Typeable (Typeable)
20 import Data.List
21 import Data.Either
22
23
24 -- Scoped modules
25 defaultModules = [    "Prelude",
26                "Data.List"
27         ]
28
29 data MyException = MyException String deriving (Show,Typeable)
30 instance Exception MyException
31
32 timeoutIO action = bracket
33         (do mainId <- myThreadId
34             installHandler sigXCPU (CatchOnce $ throwTo mainId $ MyException "Time limit exceeded.") Nothing
35             forkIO $ do
36                     threadDelay (5 * 1000 * 1000)
37                     -- Time's up. It's a good day to die.
38                     throwTo mainId (MyException "Time limit exceeded")
39
40                     {- why do we need that here?
41  -                  yield -- give the other thread a chance
42                     putStrLn "Killing main thread..."
43                     killThread mainId -- Die now, srsly.
44                     error "Time expired"
45                     -}
46         )
47
48         (killThread)
49         
50         (\_ -> do
51                 mainId <- myThreadId
52                 mvar <- newEmptyMVar
53                 forkIO $ (action >>= putMVar mvar) `catch`
54                          (\e -> throwTo mainId (e::SomeException))
55                 ret <- takeMVar mvar
56                 evaluate (length ret) -- make sure exceptions are handled here
57                 return ret
58         )
59
60 myInterpreter :: [String] -> [String] -> (String -> InterpreterT IO [a]) -> String -> IO [a]
61 myInterpreter mods imports todo exp = timeoutIO $ do
62         when (unsafe exp) $ throw (MyException "Indicators for unsafe computations found in exp")
63
64         eResult <- runInterpreter $ do
65                 set [languageExtensions := []]
66                 -- Not available in hint-3.2?
67                 -- setOptimizations All
68
69                 reset
70
71                 if null mods
72                   then do -- no need for temporary files I hope. Used by bff
73                        set [installedModulesInScope := True ]
74                        setImports defaultModules
75                   else do -- Only these modules in scope. No Prelude either!
76                        loadModules mods
77                        set [installedModulesInScope := False ]
78                        setImports imports
79         
80                 unsafeSetGhcOption "-fno-monomorphism-restriction"
81                 unsafeSetGhcOption "-fno-warn-warnings-deprecations"
82                 
83                 --liftIO $ putStrLn exp --this makes it impossible to run at www-ps.uni-bonn.de
84                 ret <- todo exp
85
86                 -- Hopefully removes temporary files
87                 reset
88                 
89                 return ret
90         
91         case eResult of
92                 Left exception -> throw exception
93                 Right result -> return result
94         
95 formatInterpreterError :: InterpreterError -> [Char]
96 formatInterpreterError (UnknownError s) = "Unknown Interpreter Error:\n" ++ s
97 formatInterpreterError (WontCompile es) = "Could not compile code:\n" ++ unlines (map errMsg es)
98 formatInterpreterError (NotAllowed s) = "Not allowed here " ++ s
99 formatInterpreterError (GhcException e) = "GHC Exception"
100         
101 {- | Return true if the String contains anywhere in it any keywords associated
102    with dangerous functions. Unfortunately, this blacklist leaks like a sieve
103    and will return many false positives (eg. 'unsafed "id \"unsafed\""' will
104    evaluate to True, even though the phrase \"unsafe\" appears only in a String). But it
105    will at least catch naive and simplistic invocations of "unsafePerformIO",
106    "inlinePerformIO", and "unsafeCoerce". -}
107 unsafe :: String -> Bool
108 unsafe = \z -> any (`isInfixOf` z) unsafeNames
109
110 unsafeNames :: [String]
111 unsafeNames = ["unsafe", "inlinePerform", "liftIO", "Coerce", "Foreign",
112                "Typeable", "Array", "IOBase", "Handle", "ByteString",
113                "Editline", "GLUT", "lock", "ObjectIO", "System.Time",
114                "OpenGL", "Control.Concurrent", "System.Posix",
115                "throw", "Dyn", "cache", "stdin", "stdout", "stderr"]
116
117 catchInterpreterErrors :: IO a -> IO (Either String a)
118 catchInterpreterErrors action = 
119         flip catch (return . Left . formatInterpreterError) $
120         flip catch (\(MyException s) -> return (Left s))   $
121         flip catch (\(ErrorCall s) -> return (Left s))   $
122         Right `fmap` action
123
124 simpleInterpret :: [String] -> [String] -> String -> String -> IO String 
125 simpleInterpret mods imports defs what = 
126         myInterpreter mods imports eval $
127            "let \n" ++
128             unlines (map (replicate 12 ' '++) (lines defs)) ++ 
129             replicate 8 ' ' ++ "in " ++ what
130
131 simpleTypeOf :: [String] -> [String] -> String -> String -> IO String 
132 simpleTypeOf mods imports defs what = 
133         myInterpreter mods imports typeOf $
134            "let \n" ++
135             unlines (map (replicate 12 ' '++) (lines defs)) ++ 
136             replicate 8 ' ' ++ "in " ++ what