-
Notifications
You must be signed in to change notification settings - Fork 0
/
Interpret.hs
147 lines (118 loc) · 4.78 KB
/
Interpret.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
-- | This module interprets strings representing rules to convert them to plain Rules.
module Nomyx.Core.Engine.Interpret (
interpretRule,
interpretRule',
showInterpreterError
)
where
import Control.Exception as CE
import Control.Monad
import Control.Monad.Catch as MC
import Data.List
import Language.Haskell.Interpreter
import Language.Haskell.Interpreter.Server
import Language.Haskell.Interpreter.Unsafe (unsafeSetGhcOption)
import Nomyx.Language
import Nomyx.Core.Engine.Context
import Nomyx.Core.Engine.Utils
import System.FilePath (dropExtension, joinPath,
takeFileName, dropFileName,
splitDirectories, takeBaseName, (</>))
import System.IO.Temp
import System.IO.Unsafe
import System.Directory
import System.Log.Logger
#ifndef WINDOWS
import qualified System.Posix.Signals as S
#endif
#ifndef NOINTER
serverHandle :: ServerHandle
serverHandle = unsafePerformIO $ start
exts :: [String]
exts = ["Safe", "GADTs"] ++ map show namedExts
namedExts :: [Extension]
namedExts = [GADTs,
ScopedTypeVariables,
TypeFamilies,
DeriveDataTypeable]
-- | initializes the interpreter by loading some modules.
initializeInterpreter :: [ModuleInfo] -> Interpreter ()
initializeInterpreter mods = do
reset
-- Interpreter options
set [installedModulesInScope := False,
languageExtensions := map readExt exts]
-- GHC options
unsafeSetGhcOption "-w"
unsafeSetGhcOption "-fpackage-trust"
forM_ (defaultPackages >>= words) $ \pkg -> unsafeSetGhcOption ("-trust " ++ pkg)
-- Modules
when (not $ null mods) $ do
dir <- liftIO $ createTempDirectory "/tmp" "Nomyx"
modPaths <- liftIO $ mapM (saveModule dir) mods
let modNames = map (getModName . _modPath) mods
info $ "Loading modules: " ++ (intercalate ", " modPaths)
info $ "module names: " ++ (intercalate ", " modNames)
loadModules modPaths
setTopLevelModules modNames
-- Imports
let importMods = qualImports ++ zip (unQualImports) (repeat Nothing)
setImportsQ importMods
getModName :: FilePath -> String
getModName fp = intercalate "." $ (filter (/= ".") $ splitDirectories $ dropFileName fp) ++ [takeBaseName fp]
---- | reads a Rule out of a string.
interpretRule :: RuleCode -> [ModuleInfo] -> IO (Either InterpreterError Rule)
interpretRule rc ms = runRule `catchIOError` handler where
runRule = protectHandlers $ runIn serverHandle $ do
initializeInterpreter ms
interpret rc (as :: Rule)
handler (e::IOException) = return $ Left $ NotAllowed $ "Caught exception: " ++ (show e)
interpretRule' :: RuleCode -> [ModuleInfo] -> IO Rule
interpretRule' rc ms = do
res <- interpretRule rc ms
case res of
Right rf -> return rf
Left e -> error $ show e
showInterpreterError :: InterpreterError -> String
showInterpreterError (UnknownError s) = "Unknown Error\n" ++ s
showInterpreterError (WontCompile ers) = "Won't Compile\n" ++ concatMap (\(GhcError errMsg) -> errMsg ++ "\n") ers
showInterpreterError (NotAllowed s) = "Not Allowed (Probable cause: bad module or file name)\n" ++ s
showInterpreterError (GhcException s) = "Ghc Exception\n" ++ s
readExt :: String -> Extension
readExt s = case reads s of
[(e,[])] -> e
_ -> UnknownExtension s
#else
interpretRule :: RuleCode -> [ModuleInfo] -> IO (Either InterpreterError Rule)
interpretRule rc ms = return $ Left $ NotAllowed "Interpreter not included"
interpretRule' :: RuleCode -> [ModuleInfo] -> IO Rule
interpretRule' rc ms = error "Interpreter not included"
showInterpreterError :: InterpreterError -> String
showInterpreterError (NotAllowed s) = s
#endif
#ifdef WINDOWS
--no signals under windows
protectHandlers :: IO a -> IO a
protectHandlers = id
#else
installHandler' :: S.Handler -> S.Signal -> IO S.Handler
installHandler' handler signal = S.installHandler signal handler Nothing
signals :: [S.Signal]
signals = [ S.sigQUIT
, S.sigINT
, S.sigHUP
, S.sigTERM
]
saveHandlers :: IO [S.Handler]
saveHandlers = liftIO $ mapM (installHandler' S.Ignore) signals
restoreHandlers :: [S.Handler] -> IO [S.Handler]
restoreHandlers h = liftIO . sequence $ zipWith installHandler' h signals
protectHandlers :: IO a -> IO a
protectHandlers a = MC.bracket saveHandlers restoreHandlers $ const a
#endif
warn, info :: (MonadIO m) => String -> m ()
info s = liftIO $ infoM "Nomyx.Core.Engine.Interpret" s
warn s = liftIO $ warningM "Nomyx.Core.Engine.Interpret" s