{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternSynonyms #-}
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 = forall st. Module st
newModule
{ moduleCmds :: ModuleT () LB [Command (ModuleT () LB)]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
[ (String -> Command Identity
command String
"run")
{ help :: Cmd (ModuleT () LB) ()
help = 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 = forall (m :: * -> *). Monad m => m String -> Cmd m ()
lim80 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadLB m => String -> m String
runGHC
}
, (String -> Command Identity
command String
"let")
{ aliases :: [String]
aliases = [String
"define"]
, help :: Cmd (ModuleT () LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"let <x> = <e>. Add a binding"
, process :: String -> Cmd (ModuleT () LB) ()
process = forall (m :: * -> *). Monad m => m String -> Cmd m ()
lim80 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadLB m => String -> m String
define
}
, (String -> Command Identity
command String
"undefine")
{ help :: Cmd (ModuleT () LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"undefine. Reset evaluator local bindings"
, process :: String -> Cmd (ModuleT () LB) ()
process = \String
s ->
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s
then do
forall (m :: * -> *). MonadLB m => m ()
resetL_hs
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Undefined."
else 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 <- forall (m :: * -> *). MonadLB m => String -> m Bool
isEval String
txt
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (forall (m :: * -> *). Monad m => m String -> Cmd m ()
lim80 (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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"-S"]
, forall a b. (a -> b) -> [a] -> [b]
map (String
"-s" forall a. [a] -> [a] -> [a]
++) [String]
trusted
, forall a b. (a -> b) -> [a] -> [b]
map (String
"-X" forall a. [a] -> [a] -> [a]
++) [String]
exts
, [String
"--no-imports", String
"-l", String
load]
, [String
"--expression=" forall a. [a] -> [a] -> [a]
++ String -> String
decodeString String
src]
, [String
"+RTS", String
"-N", String
"-RTS"]
]
isEval :: MonadLB m => String -> m Bool
isEval :: forall (m :: * -> *). MonadLB m => String -> m Bool
isEval String
str = do
[String]
prefixes <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
evalPrefixes
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
prefixes [String] -> String -> Bool
`arePrefixesWithSpaceOf` String
str)
dropPrefix :: String -> String
dropPrefix :: String -> String
dropPrefix = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
' ' forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
2
runGHC :: MonadLB m => String -> m String
runGHC :: forall (m :: * -> *). MonadLB m => String -> m String
runGHC String
src = do
String
load <- forall (m :: * -> *). MonadLB m => m String
findL_hs
String
binary <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
muevalBinary
[String]
exts <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
languageExts
[String]
trusted <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
trustedPackages
(ExitCode
_,String
out,String
err) <- 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
([],[]) -> 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case () of {()
_
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
o Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
e -> String
"Terminated\n"
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
o -> String
e
| Bool
otherwise -> String
o
}
define :: MonadLB m => String -> m String
define :: forall (m :: * -> *). MonadLB m => String -> m String
define [] = forall (m :: * -> *) a. Monad m => a -> m a
return String
"Define what?"
define String
src = do
[String]
exts <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
languageExts
let mode :: ParseMode
mode = ParseMode
Hs.defaultParseMode{ extensions :: [Extension]
Hs.extensions = 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 <- forall (m :: * -> *). MonadLB m => m String
findL_hs
ParseResult Module
res <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Pretty a => a -> String
Hs.prettyPrint SrcLoc
loc forall a. [a] -> [a] -> [a]
++ Char
':' 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return String
msg
Maybe String
Nothing -> forall (m :: * -> *). MonadLB m => Module -> m String
comp Module
merged
Hs.ParseFailed SrcLoc
_loc String
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (String
"Parse failed: " forall a. [a] -> [a] -> [a]
++ String
err)
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 = forall a. Eq a => [a] -> [a]
nub (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ImportDecl -> ModuleName ()
Hs.importModule) ([ImportDecl]
x forall a. [a] -> [a] -> [a]
++ [ImportDecl]
y))
mergeDecls :: [Decl] -> [Decl] -> [Decl]
mergeDecls [Decl]
x [Decl]
y = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Decl -> [Name ()]
funcNamesBound) ([Decl]
x forall a. [a] -> [a] -> [a]
++ [Decl]
y)
funcNamesBound :: Decl -> [Name ()]
funcNamesBound (Hs.FunBind [Match]
ms) = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name ()]
langs = forall a. a -> Maybe a
Just String
"Module has no \"Safe\" language pragma"
| Name ()
trusted forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name ()]
langs = forall a. a -> Maybe a
Just String
"\"Trustworthy\" language pragma is set"
| Bool
otherwise = 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 = 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
comp :: MonadLB m => Hs.Module -> m String
comp :: forall (m :: * -> *). MonadLB m => Module -> m String
comp Module
src = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
writeFile String
".L.hs" (forall a. Pretty a => a -> String
Hs.prettyPrint Module
src))
[String]
trusted <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
trustedPackages
let ghcArgs :: [String]
ghcArgs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"-O", String
"-v0", String
"-c", String
"-Werror", String
"-fpackage-trust"]
, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String
"-trust", String
pkg] | String
pkg <- [String]
trusted]
, [String
".L.hs"]
]
String
ghc <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
ghcBinary
(ExitCode
c, String
o',String
e') <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
ghc [String]
ghcArgs String
"")
Either SomeException ()
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO ()
removeFile String
".L.hi") :: IO (Either SomeException ()))
Either SomeException ()
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (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 forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> IO ()
removeFile String
".L.hs")
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Error."
| Bool
otherwise -> do
String
l <- forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findLBFileForWriting String
"L.hs")
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
moveFile String
".L.hs" String
l)
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Defined."
(String
ee,[]) -> forall (m :: * -> *) a. Monad m => a -> m a
return String
ee
(String
_ ,String
ee) -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
strip (forall a. Eq a => a -> a -> Bool
==Char
'\n')
mungeEnc :: String -> String
mungeEnc = String -> String
encodeString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
munge
resetL_hs :: MonadLB m => m ()
resetL_hs :: forall (m :: * -> *). MonadLB m => m ()
resetL_hs = do
String
p <- forall (m :: * -> *). MonadLB m => m String
findPristine_hs
String
l <- forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findLBFileForWriting String
"L.hs")
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
copyFile String
p String
l)
findPristine_hs :: MonadLB m => m FilePath
findPristine_hs :: forall (m :: * -> *). MonadLB m => m String
findPristine_hs = do
Maybe String
p <- 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 <- forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findOrCreateLBFile String
"Pristine.hs")
Maybe String
p0 <- forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB (Maybe String)
findLBFileForReading (String
"Pristine.hs." forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show __GLASGOW_HASKELL__))
Maybe String
p0 <- case Maybe String
p0 of
Maybe String
Nothing -> forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB (Maybe String)
findLBFileForReading String
"Pristine.hs.default")
Maybe String
p0 -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
p0
case Maybe String
p0 of
Just String
p0 -> do
String
p <- forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findLBFileForWriting String
"Pristine.hs")
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
copyFile String
p0 String
p)
Maybe String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return String
p
Just String
p -> forall (m :: * -> *) a. Monad m => a -> m a
return String
p
findL_hs :: MonadLB m => m FilePath
findL_hs :: forall (m :: * -> *). MonadLB m => m String
findL_hs = do
Maybe String
file <- forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB (Maybe String)
findLBFileForReading String
"L.hs")
case Maybe String
file of
Maybe String
Nothing -> forall (m :: * -> *). MonadLB m => m ()
resetL_hs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findOrCreateLBFile String
"L.hs")
Just String
file -> forall (m :: * -> *) a. Monad m => a -> m a
return String
file