Add type signatures to MyInterpret
[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.GHC.Unsafe
12
13 import Prelude hiding (catch)
14 import Control.Concurrent
15 import Control.OldException
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 modules = [    "Prelude",
26                "Data.List"
27         ]
28
29 data MyException = MyException String deriving (Typeable)
30
31 timeoutIO action = bracket
32         (do mainId <- myThreadId
33             installHandler sigXCPU (CatchOnce $ throwDynTo mainId $ MyException "Time limit exceeded.") Nothing
34             forkIO $ do
35                     threadDelay (5 * 1000 * 1000)
36                     -- Time's up. It's a good day to die.
37                     throwDynTo mainId (MyException "Time limit exceeded")
38
39                     {- why do we need that here?
40  -                  yield -- give the other thread a chance
41                     putStrLn "Killing main thread..."
42                     killThread mainId -- Die now, srsly.
43                     error "Time expired"
44                     -}
45         )
46
47         (killThread)
48         
49         (\_ -> do
50                 mainId <- myThreadId
51                 mvar <- newEmptyMVar
52                 forkIO $ (action >>= putMVar mvar) `catch`
53                          (throwTo mainId)      
54                 ret <- takeMVar mvar
55                 evaluate (length ret) -- make sure exceptions are handled here
56                 return ret
57         )
58
59 myInterpreter :: (String -> InterpreterT IO [a]) -> String -> IO [a]
60 myInterpreter todo exp = timeoutIO $ do
61         when (unsafe exp) $ throwDyn (MyException "Indicators for unsafe computations found in exp")
62
63         eResult <- runInterpreter $ do
64                 setUseLanguageExtensions False
65                 -- Not available in hint-3.2?
66                 -- setOptimizations All
67
68                 reset
69                 -- no need for temporary files I hope
70                 setInstalledModsAreInScopeQualified True 
71         
72                 unsafeSetGhcOption "-fno-monomorphism-restriction"
73                 
74                 setImports modules
75                 
76                 liftIO $ putStrLn exp
77                 todo exp
78         
79         case eResult of
80                 Left exception -> throw exception
81                 Right result -> return result
82         
83 formatInterpreterError :: InterpreterError -> [Char]
84 formatInterpreterError (UnknownError s) = "Unknown Interpreter Error " ++ s
85 formatInterpreterError (WontCompile es) = "Could not compile code:\n" ++ unlines (map errMsg es)
86 formatInterpreterError (NotAllowed s) = "Not allowed here " ++ s
87 formatInterpreterError (GhcException e) = "GHC Exception"
88         
89 {- | Return true if the String contains anywhere in it any keywords associated
90    with dangerous functions. Unfortunately, this blacklist leaks like a sieve
91    and will return many false positives (eg. 'unsafed "id \"unsafed\""' will
92    evaluate to True, even though the phrase \"unsafe\" appears only in a String). But it
93    will at least catch naive and simplistic invocations of "unsafePerformIO",
94    "inlinePerformIO", and "unsafeCoerce". -}
95 unsafe :: String -> Bool
96 unsafe = \z -> any (`isInfixOf` z) unsafeNames
97
98 unsafeNames :: [String]
99 unsafeNames = ["unsafe", "inlinePerform", "liftIO", "Coerce", "Foreign",
100                "Typeable", "Array", "IOBase", "Handle", "ByteString",
101                "Editline", "GLUT", "lock", "ObjectIO", "System.Time",
102                "OpenGL", "Control.Concurrent", "System.Posix",
103                "throw", "Dyn", "cache", "stdin", "stdout", "stderr"]
104
105 catchInterpreterErrors :: IO a -> IO (Either String a)
106 catchInterpreterErrors action = 
107         flip catchDyn (return . Left . formatInterpreterError) $
108         flip catchDyn (\(MyException s) -> return (Left s))   $
109         handleJust errorCalls (return . Left)                  $ -- bff in Bff.hs uses these
110         Right `fmap` action
111
112 simpleInterpret :: String -> String -> IO String 
113 simpleInterpret defs what = 
114         myInterpreter eval $
115            "let \n" ++
116             unlines (map (replicate 12 ' '++) (lines defs)) ++ 
117             replicate 8 ' ' ++ "in " ++ what
118
119 simpleTypeOf :: String -> String -> IO String 
120 simpleTypeOf defs what = 
121         myInterpreter typeOf $
122            "let \n" ++
123             unlines (map (replicate 12 ' '++) (lines defs)) ++ 
124             replicate 8 ' ' ++ "in " ++ what