{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternSynonyms #-}

-- Copyright (c) 2004-6 Donald Bruce Stewart - http://www.cse.unsw.edu.au/~dons
-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)

-- | A Haskell evaluator for the pure part, using mueval
module Lambdabot.Plugin.Haskell.Eval (evalPlugin, runGHC, findL_hs) where

import Lambdabot.Config.Haskell
import Lambdabot.Plugin
import Lambdabot.Util
import Lambdabot.Util.Browser

import Control.Exception (try, SomeException)
import Control.Monad
import Data.List
import Data.Ord
import qualified Language.Haskell.Exts.Simple as Hs
import System.Directory
import System.Exit
import System.Process
import Codec.Binary.UTF8.String

evalPlugin :: Module ()
evalPlugin :: Module ()
evalPlugin = Module ()
forall st. Module st
newModule
    { moduleCmds :: ModuleT () LB [Command (ModuleT () LB)]
moduleCmds = [Command (ModuleT () LB)]
-> ModuleT () LB [Command (ModuleT () LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"run")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"run <expr>. You have Haskell, 3 seconds and no IO. Go nuts!"
            , process :: String -> Cmd (ModuleT () LB) ()
process = ModuleT () LB String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => m String -> Cmd m ()
lim80 (ModuleT () LB String -> Cmd (ModuleT () LB) ())
-> (String -> ModuleT () LB String)
-> String
-> Cmd (ModuleT () LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleT () LB String
forall (m :: * -> *). MonadLB m => String -> m String
runGHC
            }
        , (String -> Command Identity
command String
"let")
            { aliases :: [String]
aliases = [String
"define"] -- because @define always gets "corrected" to @undefine
            , help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"let <x> = <e>. Add a binding"
            , process :: String -> Cmd (ModuleT () LB) ()
process = ModuleT () LB String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => m String -> Cmd m ()
lim80 (ModuleT () LB String -> Cmd (ModuleT () LB) ())
-> (String -> ModuleT () LB String)
-> String
-> Cmd (ModuleT () LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleT () LB String
forall (m :: * -> *). MonadLB m => String -> m String
define
            }
        , (String -> Command Identity
command String
"undefine")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"undefine. Reset evaluator local bindings"
            , process :: String -> Cmd (ModuleT () LB) ()
process = \String
s ->
                if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s
                    then do
                        Cmd (ModuleT () LB) ()
forall (m :: * -> *). MonadLB m => m ()
resetL_hs
                        String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Undefined."
                    else String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"There's currently no way to undefine just one thing.  Say @undefine (with no extra words) to undefine everything."
            }
        ]

    , contextual :: String -> Cmd (ModuleT () LB) ()
contextual = \String
txt -> do
        Bool
b <- String -> Cmd (ModuleT () LB) Bool
forall (m :: * -> *). MonadLB m => String -> m Bool
isEval String
txt
        Bool -> Cmd (ModuleT () LB) () -> Cmd (ModuleT () LB) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (ModuleT () LB String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => m String -> Cmd m ()
lim80 (String -> ModuleT () LB String
forall (m :: * -> *). MonadLB m => String -> m String
runGHC (String -> String
dropPrefix String
txt)))
    }

args :: String -> String -> [String] -> [String] -> [String]
args :: String -> String -> [String] -> [String] -> [String]
args String
load String
src [String]
exts [String]
trusted = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [String
"-S"]
    , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-s" String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
trusted
    , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-X" String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
exts
    , [String
"--no-imports", String
"-l", String
load]
    , [String
"--expression=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
decodeString String
src]
    , [String
"+RTS", String
"-N", String
"-RTS"]
    ]

isEval :: MonadLB m => String -> m Bool
isEval :: String -> m Bool
isEval String
str = do
    [String]
prefixes <- Config [String] -> m [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
evalPrefixes
    Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
prefixes [String] -> String -> Bool
`arePrefixesWithSpaceOf` String
str)

dropPrefix :: String -> String
dropPrefix :: String -> String
dropPrefix = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
' ' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2

runGHC :: MonadLB m => String -> m String
runGHC :: String -> m String
runGHC String
src = do
    String
load    <- m String
forall (m :: * -> *). MonadLB m => m String
findL_hs
    String
binary  <- Config String -> m String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
muevalBinary
    [String]
exts    <- Config [String] -> m [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
languageExts
    [String]
trusted <- Config [String] -> m [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
trustedPackages
    (ExitCode
_,String
out,String
err) <- IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
binary (String -> String -> [String] -> [String] -> [String]
args String
load String
src [String]
exts [String]
trusted) String
"")
    case (String
out,String
err) of
        ([],[]) -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Terminated\n"
        (String, String)
_       -> do
            let o :: String
o = String -> String
mungeEnc String
out
                e :: String
e = String -> String
mungeEnc String
err
            String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ case () of {()
_
                | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
o Bool -> Bool -> Bool
&& String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
e -> String
"Terminated\n"
                | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
o           -> String
e
                | Bool
otherwise        -> String
o
            }

------------------------------------------------------------------------
-- define a new binding

define :: MonadLB m => String -> m String
define :: String -> m String
define [] = String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Define what?"
define String
src = do
    [String]
exts <- Config [String] -> m [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
languageExts
    let mode :: ParseMode
mode = ParseMode
Hs.defaultParseMode{ extensions :: [Extension]
Hs.extensions = (String -> Extension) -> [String] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map String -> Extension
Hs.classifyExtension [String]
exts }
    case ParseMode -> String -> ParseResult Module
Hs.parseModuleWithMode ParseMode
mode (String -> String
decodeString String
src) of
        Hs.ParseOk Module
srcModule -> do
            String
l <- m String
forall (m :: * -> *). MonadLB m => m String
findL_hs
            ParseResult Module
res <- IO (ParseResult Module) -> m (ParseResult Module)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> IO (ParseResult Module)
Hs.parseFile String
l)
            case ParseResult Module
res of
                Hs.ParseFailed SrcLoc
loc String
err -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcLoc -> String
forall a. Pretty a => a -> String
Hs.prettyPrint SrcLoc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: String
err)
                Hs.ParseOk Module
lModule -> do
                    let merged :: Module
merged = Module -> Module -> Module
mergeModules Module
lModule Module
srcModule
                    case Module -> Maybe String
moduleProblems Module
merged of
                        Just String
msg -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
msg
                        Maybe String
Nothing  -> Module -> m String
forall (m :: * -> *). MonadLB m => Module -> m String
comp Module
merged
        Hs.ParseFailed SrcLoc
_loc String
err -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"Parse failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)

-- merge the second module _into_ the first - meaning where merging doesn't
-- make sense, the field from the first will be used
mergeModules :: Hs.Module -> Hs.Module -> Hs.Module
mergeModules :: Module -> Module -> Module
mergeModules (Hs.Module  Maybe ModuleHead
head1  [ModulePragma]
exports1 [ImportDecl]
imports1 [Decl]
decls1)
             (Hs.Module Maybe ModuleHead
_head2 [ModulePragma]
_exports2 [ImportDecl]
imports2 [Decl]
decls2)
    = Maybe ModuleHead
-> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module
Hs.Module Maybe ModuleHead
head1 [ModulePragma]
exports1
        ([ImportDecl] -> [ImportDecl] -> [ImportDecl]
mergeImports [ImportDecl]
imports1 [ImportDecl]
imports2)
        ([Decl] -> [Decl] -> [Decl]
mergeDecls   [Decl]
decls1   [Decl]
decls2)
    where
        mergeImports :: [ImportDecl] -> [ImportDecl] -> [ImportDecl]
mergeImports [ImportDecl]
x [ImportDecl]
y = [ImportDecl] -> [ImportDecl]
forall a. Eq a => [a] -> [a]
nub ((ImportDecl -> ImportDecl -> Ordering)
-> [ImportDecl] -> [ImportDecl]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((ImportDecl -> ModuleName ())
-> ImportDecl -> ImportDecl -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ImportDecl -> ModuleName ()
Hs.importModule) ([ImportDecl]
x [ImportDecl] -> [ImportDecl] -> [ImportDecl]
forall a. [a] -> [a] -> [a]
++ [ImportDecl]
y))
        mergeDecls :: [Decl] -> [Decl] -> [Decl]
mergeDecls [Decl]
x [Decl]
y = (Decl -> Decl -> Ordering) -> [Decl] -> [Decl]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Decl -> [Name]) -> Decl -> Decl -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Decl -> [Name]
funcNamesBound) ([Decl]
x [Decl] -> [Decl] -> [Decl]
forall a. [a] -> [a] -> [a]
++ [Decl]
y)

        -- this is a very conservative measure... we really only even care about function names,
        -- because we just want to sort those together so clauses can be added in the right places
        -- TODO: find out whether the [Hs.Match] can contain clauses for more than one function (e,g. might it be a whole binding group?)
        funcNamesBound :: Decl -> [Name]
funcNamesBound (Hs.FunBind [Match]
ms) = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. Ord a => [a] -> [a]
sort [ Name
n | Hs.Match Name
n [Pat]
_ Rhs
_ Maybe Binds
_ <- [Match]
ms]
        funcNamesBound Decl
_ = []

moduleProblems :: Hs.Module -> Maybe [Char]
moduleProblems :: Module -> Maybe String
moduleProblems (Hs.Module Maybe ModuleHead
_head [ModulePragma]
pragmas [ImportDecl]
_imports [Decl]
_decls)
    | Name
safe Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
langs  = String -> Maybe String
forall a. a -> Maybe a
Just String
"Module has no \"Safe\" language pragma"
    | Name
trusted Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
langs  = String -> Maybe String
forall a. a -> Maybe a
Just String
"\"Trustworthy\" language pragma is set"
    | Bool
otherwise             = Maybe String
forall a. Maybe a
Nothing
    where
        safe :: Name
safe    = String -> Name
Hs.name String
"Safe"
        trusted :: Name
trusted = String -> Name
Hs.name String
"Trustworthy"
        langs :: [Name]
langs = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Name]
ls | Hs.LanguagePragma [Name]
ls <- [ModulePragma]
pragmas ]

moveFile :: FilePath -> FilePath -> IO ()
moveFile :: String -> String -> IO ()
moveFile String
from String
to = do
  String -> String -> IO ()
copyFile String
from String
to
  String -> IO ()
removeFile String
from

-- It parses. then add it to a temporary L.hs and typecheck
comp :: MonadLB m => Hs.Module -> m String
comp :: Module -> m String
comp Module
src = do
    -- Note we copy to .L.hs, not L.hs. This hides the temporary files as dot-files
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
writeFile String
".L.hs" (Module -> String
forall a. Pretty a => a -> String
Hs.prettyPrint Module
src))

    -- and compile .L.hs
    -- careful with timeouts here. need a wrapper.
    [String]
trusted <- Config [String] -> m [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
trustedPackages
    let ghcArgs :: [String]
ghcArgs = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [String
"-O", String
"-v0", String
"-c", String
"-Werror", String
"-fpackage-trust"]
            , [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String
"-trust", String
pkg] | String
pkg <- [String]
trusted]
            , [String
".L.hs"]
            ]
    String
ghc <- Config String -> m String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
ghcBinary
    (ExitCode
c, String
o',String
e') <- IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
ghc [String]
ghcArgs String
"")
    -- cleanup, 'try' because in case of error the files are not generated
    Either SomeException ()
_ <- IO (Either SomeException ()) -> m (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO ()
removeFile String
".L.hi") :: IO (Either SomeException ()))
    Either SomeException ()
_ <- IO (Either SomeException ()) -> m (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO ()
removeFile String
".L.o")  :: IO (Either SomeException ()))

    case (String -> String
mungeEnc String
o', String -> String
mungeEnc String
e') of
        ([],[]) | ExitCode
c ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess -> do
                    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> IO ()
removeFile String
".L.hs")
                    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Error."
                | Bool
otherwise -> do
                    String
l <- LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findLBFileForWriting String
"L.hs")
                    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
moveFile String
".L.hs" String
l)
                    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Defined."
        (String
ee,[]) -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
ee
        (String
_ ,String
ee) -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
ee

munge, mungeEnc :: String -> String
munge :: String -> String
munge = Int -> String -> String
expandTab Int
8 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
strip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n')
mungeEnc :: String -> String
mungeEnc = String -> String
encodeString (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
munge

------------------------------
-- reset all bindings

resetL_hs :: MonadLB m => m ()
resetL_hs :: m ()
resetL_hs = do
    String
p <- m String
forall (m :: * -> *). MonadLB m => m String
findPristine_hs
    String
l <- LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findLBFileForWriting String
"L.hs")
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
copyFile String
p String
l)

-- find Pristine.hs; if not found, we try to install a compiler-specific
-- version from lambdabot's data directory, and finally the default one.
findPristine_hs :: MonadLB m => m FilePath
findPristine_hs :: m String
findPristine_hs = do
    Maybe String
p <- LB (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB (Maybe String)
findLBFileForReading String
"Pristine.hs")
    case Maybe String
p of
        Maybe String
Nothing -> do
            String
p <- LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findOrCreateLBFile String
"Pristine.hs")
            Maybe String
p0 <- LB (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB (Maybe String)
findLBFileForReading (String
"Pristine.hs." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show __GLASGOW_HASKELL__))
            Maybe String
p0 <- case Maybe String
p0 of
                Maybe String
Nothing -> LB (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB (Maybe String)
findLBFileForReading String
"Pristine.hs.default")
                Maybe String
p0 -> Maybe String -> m (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
p0
            case Maybe String
p0 of
                Just String
p0 -> do
                    String
p <- LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findLBFileForWriting String
"Pristine.hs")
                    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
copyFile String
p0 String
p)
                Maybe String
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
p
        Just String
p -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
p

-- find L.hs; if not found, we copy it from Pristine.hs
findL_hs :: MonadLB m => m FilePath
findL_hs :: m String
findL_hs = do
    Maybe String
file <- LB (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB (Maybe String)
findLBFileForReading String
"L.hs")
    case Maybe String
file of
        -- if L.hs
        Maybe String
Nothing -> m ()
forall (m :: * -> *). MonadLB m => m ()
resetL_hs m () -> m String -> m String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findOrCreateLBFile String
"L.hs")
        Just String
file -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
file