Interpreter.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternGuards #-}

-- TODO: suggest the convenience functions be put into Hint proper?
module Mueval.Interpreter where

import qualified Control.Exception.Extensible as E (SomeException (..), catch, evaluate)
import Control.Monad (forM_, guard, mplus, unless, when)
import Control.Monad.Trans (MonadIO)
import Control.Monad.Writer (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 Data.Monoid (Any (..))

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

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

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) =>
    -- | max number of characters to include
    Int ->
    -- | input
    String ->
    -- | ( output, @True@ if we found an exception )
    m (String, Bool)
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)

-- Copied from old hint, removed from hint since 0.5.0.
glasgowExtensions :: [Extension]
glasgowExtensions = intersect availableExtensions exts612 -- works also for 608 and 610
  where
    exts612 =
        map
            readExt
            [ "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"
            ]