    {-# LANGUAGE PatternGuards #-}
    -- TODO: suggest the convenience functions be put into Hint proper?
    module Mueval.Interpreter where

    import Control.Monad (guard,mplus,unless,when)
    import Control.Monad.Trans (MonadIO)
    import Control.Monad.Writer (Any(..),runWriterT,tell)
    import Data.Char (isDigit)
    import Data.List (stripPrefix)
    import System.Directory (copyFile, makeRelativeToCurrentDirectory, setCurrentDirectory)
    import System.Exit (exitFailure)
    import System.FilePath.Posix (takeFileName)
    import qualified Control.Exception.Extensible as E (evaluate,catch,SomeException(..))

    import qualified System.IO.UTF8 as UTF (putStrLn)

    import Language.Haskell.Interpreter (eval, set, reset, setImportsQ, loadModules, liftIO,
                                         installedModulesInScope, languageExtensions,
                                         typeOf, setTopLevelModules, runInterpreter, glasgowExtensions,
                                         OptionVal(..), Interpreter,
                                         InterpreterError(..),GhcError(..))

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

    {- | 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,
                          loadFile = load, expression = expr,
                          modules = m } = do
                                      let lexts = (guard exts >> glasgowExtensions) ++ map read nexts
                                      unless (null lexts) $ set [languageExtensions := lexts]

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

                                      when (load /= "") $ do liftIO (mvload load)
                                                             let lfl' = takeFileName load
                                                             loadModules [lfl']
                                                             -- We need to mangle the String to
                                                             -- turn a filename into a module.
                                                             setTopLevelModules [takeWhile (/='.') lfl']

                                      liftIO $ MR.limitResources rlimits

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

                                      -- we don't check if the expression typechecks
                                      -- this way we get an "InterpreterError" we can display
                                      etype <- typeOf expr
                                      result <- 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) -> when (printType opts) (sayIO e >> sayIO et) >> sayIO val

    mvload :: FilePath -> IO ()
    mvload lfl = do canonfile <- makeRelativeToCurrentDirectory lfl
                    liftIO $ copyFile canonfile $ "/tmp/" ++ takeFileName canonfile
                    setCurrentDirectory "/tmp" -- will at least mess up relative links

    ---------------------------------
    -- 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
                   UTF.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)
              => 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)