Add hint to .cabal
[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 -> IO String
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 (UnknownError s) = "Unknown Interpreter Error " ++ s
84 formatInterpreterError (WontCompile es) = "Could not compile code:\n" ++ unlines (map errMsg es)
85 formatInterpreterError (NotAllowed s) = "Not allowed here " ++ s
86 formatInterpreterError (GhcException e) = "GHC Exception"
87         
88 {- | Return true if the String contains anywhere in it any keywords associated
89    with dangerous functions. Unfortunately, this blacklist leaks like a sieve
90    and will return many false positives (eg. 'unsafed "id \"unsafed\""' will
91    evaluate to True, even though the phrase \"unsafe\" appears only in a String). But it
92    will at least catch naive and simplistic invocations of "unsafePerformIO",
93    "inlinePerformIO", and "unsafeCoerce". -}
94 unsafe :: String -> Bool
95 unsafe = \z -> any (`isInfixOf` z) unsafeNames
96
97 unsafeNames :: [String]
98 unsafeNames = ["unsafe", "inlinePerform", "liftIO", "Coerce", "Foreign",
99                "Typeable", "Array", "IOBase", "Handle", "ByteString",
100                "Editline", "GLUT", "lock", "ObjectIO", "System.Time",
101                "OpenGL", "Control.Concurrent", "System.Posix",
102                "throw", "Dyn", "cache", "stdin", "stdout", "stderr"]
103
104 catchInterpreterErrors :: IO a -> IO (Either String a)
105 catchInterpreterErrors action = 
106         flip catchDyn (return . Left . formatInterpreterError) $
107         flip catchDyn (\(MyException s) -> return (Left s))   $
108         handleJust errorCalls (return . Left)                  $ -- bff in Bff.hs uses these
109         Right `fmap` action
110
111 simpleInterpret :: String -> String -> IO String 
112 simpleInterpret defs what = 
113         myInterpreter eval $
114            "let \n" ++
115             unlines (map (replicate 12 ' '++) (lines defs)) ++ 
116             replicate 8 ' ' ++ "in " ++ what
117
118 simpleTypeOf :: String -> String -> IO String 
119 simpleTypeOf defs what = 
120         myInterpreter typeOf $
121            "let \n" ++
122             unlines (map (replicate 12 ' '++) (lines defs)) ++ 
123             replicate 8 ' ' ++ "in " ++ what