File: Interpreter.hs

package info (click to toggle)
haskell-mueval 0.9.1.1.2-9
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 164 kB
  • ctags: 1
  • sloc: haskell: 429; sh: 85; makefile: 4
file content (216 lines) | stat: -rw-r--r-- 11,100 bytes parent folder | download
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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
-- TODO: suggest the convenience functions be put into Hint proper?
module Mueval.Interpreter where

import qualified Control.Exception.Extensible as E (evaluate,catch,SomeException(..))
import           Control.Monad (forM_,guard,mplus,unless,when)
import           Control.Monad.Trans (MonadIO)
import           Control.Monad.Writer (Any(..),runWriterT,tell)
import           Data.Char (isDigit)

import           System.Directory

import           System.Exit (exitFailure)
import           System.FilePath.Posix (takeBaseName)
import           System.IO (openTempFile)

import           Data.List

import           Language.Haskell.Interpreter (eval, set, reset, setImportsQ, loadModules, liftIO,
                                     installedModulesInScope, languageExtensions, availableExtensions,
                                     typeOf, setTopLevelModules, runInterpreter,
                                     OptionVal(..), Interpreter,
                                     InterpreterError(..),GhcError(..),
                                     Extension(UnknownExtension))
import           Language.Haskell.Interpreter.Extension (asExtension)
import           Language.Haskell.Interpreter.Unsafe (unsafeSetGhcOption)

import           Mueval.ArgsParse (Options(..))
import qualified Mueval.Resources as MR (limitResources)
import qualified Mueval.Context as MC (qualifiedModules)

readExt :: String -> Extension
readExt s = case reads s of
  [(e,[])] -> e
  _        -> UnknownExtension s

{- | The actual calling of Hint functionality. The heart of this just calls
   'eval', but we do so much more - we disable Haskell extensions,
   hide all packages, make sure one cannot call unimported
   functions, typecheck, set resource limits for this
   thread, and do some error handling. -}
interpreter :: Options -> Interpreter (String,String,String)
interpreter Options { extensions = exts, namedExtensions = nexts,
                      rLimits = rlimits,
                      typeOnly = noEval,
                      loadFile = load, expression = expr,
                      packageTrust = trust,
                      trustedPackages = trustPkgs,
                      modules = m } = do
                                  let lexts = (guard exts >> glasgowExtensions) ++ map readExt nexts
                                  -- Explicitly adding ImplicitPrelude because of
                                  -- http://darcsden.com/jcpetruzza/hint/issue/1
                                  unless (null lexts) $ set [languageExtensions := (UnknownExtension "ImplicitPrelude" : lexts)]
                                  when trust $ do
                                    unsafeSetGhcOption "-fpackage-trust"
                                    forM_ (trustPkgs >>= words) $ \pkg ->
                                      unsafeSetGhcOption ("-trust " ++ pkg)

                                  reset -- Make sure nothing is available
                                  set [installedModulesInScope := False]

                                  -- if we're given a file of definitions, we need to first copy it to a temporary file in /tmp (cpload),
                                  -- then tell Hint to parse/read it, then extract the 'module name' of the file,
                                  -- and tell Hint to expose the module into memory; then we need to store the temporary file's filepath
                                  -- so we can try to clean up after ourselves later.
                                  lfl' <- if (load /= "") then (do { lfl <- liftIO (cpload load);
                                                                     loadModules [lfl];
                                                                     -- We need to mangle the String to
                                                                     -- turn a filename into a module.
                                                                     setTopLevelModules [takeBaseName load];
                                                                     return lfl }) else (return "")

                                  liftIO $ MR.limitResources rlimits

                                  case m of
                                    Nothing -> return ()
                                    Just ms -> do let unqualModules =  zip ms (repeat Nothing)
                                                  setImportsQ (unqualModules ++ MC.qualifiedModules)

                                  -- clean up our tmp file here; must be *after* setImportsQ
                                  when (load /= "") $ liftIO (removeFile lfl')

                                  -- we don't deliberately don't check if the expression typechecks
                                  -- this way we get an "InterpreterError" we can display
                                  etype <- typeOf expr
                                  result <- if noEval
                                               then return ""
                                               else eval expr

                                  return (expr, etype, result)

-- | Wrapper around 'interpreter'; supplies a fresh GHC API session and
-- error-handling. The arguments are largely passed on, and the results lightly parsed.
interpreterSession :: Options -> IO ()
interpreterSession opts = do r <- runInterpreter (interpreter opts)
                             case r of
                                 Left err -> printInterpreterError err
                                 Right (e,et,val) -> do when (printType opts)
                                                             (sayIO e >> sayIOOneLine et)
                                                        sayIO val
  where sayIOOneLine = sayIO . unwords . words

-- | Given a filepath (containing function definitions), copy it to a temporary file and change directory to it, returning the new filepath.
cpload :: FilePath -> IO FilePath
cpload definitions = do
                tmpdir <- getTemporaryDirectory
                (tempfile,_) <- System.IO.openTempFile tmpdir "mueval.hs"
                liftIO $ copyFile definitions tempfile
                setCurrentDirectory tmpdir -- will at least mess up relative links
                return tempfile

---------------------------------
-- Handling and outputting results
-- TODO: this whole section is a hack

-- | Print the String (presumably the result
-- of interpreting something), but only print the first 1024 characters to avoid
-- flooding. Lambdabot has a similar limit.
sayIO :: String -> IO ()
sayIO str = do (out,b) <- render 1024 str
               putStrLn out
               when b exitFailure

-- | Oh no, something has gone wrong. If it's a compilation error pretty print
-- the first 1024 chars of it and throw an "ExitException"
-- otherwise rethrow the exception in String form.
printInterpreterError :: InterpreterError -> IO ()
printInterpreterError (WontCompile errors) =
    -- if we get a compilation error we print it directly to avoid \"mueval: ...\"
    -- maybe it should go to stderr?
    do sayIO $ concatMap (dropLinePosition . errMsg) errors
       exitFailure
    where
      -- each error starts with the line position, which is uninteresting
      dropLinePosition e
          | Just s <- parseErr e =  s
          | otherwise = e -- if the parse fails we fallback on printing the whole error
      parseErr e = do s <- stripPrefix "<interactive>:" e
                      skipSpaces =<< (skipNumber =<< skipNumber s)
      skip x (y:xs) | x == y = Just xs
                    | otherwise = Nothing
      skip _ _ = Nothing
      skipNumber = skip ':' . dropWhile isDigit
      skipSpaces xs = let xs' = dropWhile (==' ') xs
                      in skip '\n' xs' `mplus` return xs'

-- other exceptions indicate some problem in Mueval or the environment,
-- so we rethrow them for debugging purposes
printInterpreterError other = error (show other)

-- Constant
exceptionMsg :: String
exceptionMsg = "*Exception: "

-- | Renders the input String including its exceptions using @exceptionMsg@
render :: (Control.Monad.Trans.MonadIO m, Functor m)
          => Int -- ^ max number of characters to include
          -> String -- ^ input
          -> m (String, Bool) -- ^ ( output, @True@ if we found an exception )
render i xs =
    do (out,Any b) <- runWriterT $ render' i (toStream xs)
       return (out,b)
    where
      render' n _ | n <= 0 = return ""
      render' n s = render'' n =<< liftIO s

      render'' _ End = return ""
      render'' n (Cons x s) = fmap (x:) $ render' (n-1) s
      render'' n (Exception s) = do
        tell (Any True)
        fmap (take n exceptionMsg ++) $ render' (n - length exceptionMsg) s

data Stream = Cons Char (IO Stream) | Exception (IO Stream) | End

toStream :: String -> IO Stream
toStream str = E.evaluate (uncons str) `E.catch`
                \(E.SomeException e) -> return . Exception . toStream . show $ e
    where uncons [] = End
          uncons (x:xs) = x `seq` Cons x (toStream xs)

glasgowExtensions :: [Extension]
glasgowExtensions = intersect availableExtensions exts612
    where exts612 = map asExtension ["PrintExplicitForalls",
                                     "ForeignFunctionInterface",
                                     "UnliftedFFITypes",
                                     "GADTs",
                                     "ImplicitParams",
                                     "ScopedTypeVariables",
                                     "UnboxedTuples",
                                     "TypeSynonymInstances",
                                     "StandaloneDeriving",
                                     "DeriveDataTypeable",
                                     "FlexibleContexts",
                                     "FlexibleInstances",
                                     "ConstrainedClassMethods",
                                     "MultiParamTypeClasses",
                                     "FunctionalDependencies",
                                     "MagicHash",
                                     "PolymorphicComponents",
                                     "ExistentialQuantification",
                                     "UnicodeSyntax",
                                     "PostfixOperators",
                                     "PatternGuards",
                                     "LiberalTypeSynonyms",
                                     "ExplicitForAll",
                                     "RankNTypes",
                                     "ImpredicativeTypes",
                                     "TypeOperators",
                                     "RecursiveDo",
                                     "DoRec",
                                     "ParallelListComp",
                                     "EmptyDataDecls",
                                     "KindSignatures",
                                     "GeneralizedNewtypeDeriving",
                                     "TypeFamilies" ]