{-# 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 = 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 "run")
{ help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "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 "let")
{ aliases :: [String]
aliases = ["define"]
, help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "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 "undefine")
{ help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "undefine. Reset evaluator local bindings"
, process :: String -> Cmd (ModuleT () LB) ()
process = \s :: 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 "Undefined."
else String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "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 = \txt :: 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 load :: String
load src :: String
src exts :: [String]
exts trusted :: [String]
trusted = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ ["-S"]
, (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("-s" String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
trusted
, (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("-X" String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
exts
, ["--no-imports", "-l", String
load]
, ["--expression=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
decodeString String
src]
, ["+RTS", "-N", "-RTS"]
]
isEval :: MonadLB m => String -> m Bool
isEval :: String -> m Bool
isEval str :: 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 -> 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 2
runGHC :: MonadLB m => String -> m String
runGHC :: String -> m String
runGHC src :: 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
(_,out :: String
out,err :: 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) "")
case (String
out,String
err) of
([],[]) -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return "Terminated\n"
_ -> 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 -> "Terminated\n"
| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
o -> String
e
| Bool
otherwise -> String
o
}
define :: MonadLB m => String -> m String
define :: String -> m String
define [] = String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return "Define what?"
define src :: 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 srcModule :: 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 loc :: SrcLoc
loc err :: 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 -> String -> String
forall a. a -> [a] -> [a]
: String
err)
Hs.ParseOk lModule :: Module
lModule -> do
let merged :: Module
merged = Module -> Module -> Module
mergeModules Module
lModule Module
srcModule
case Module -> Maybe String
moduleProblems Module
merged of
Just msg :: String
msg -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
msg
Nothing -> Module -> m String
forall (m :: * -> *). MonadLB m => Module -> m String
comp Module
merged
Hs.ParseFailed _loc :: SrcLoc
_loc err :: String
err -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return ("Parse failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
mergeModules :: Hs.Module -> Hs.Module -> Hs.Module
mergeModules :: Module -> Module -> Module
mergeModules (Hs.Module head1 :: Maybe ModuleHead
head1 exports1 :: [ModulePragma]
exports1 imports1 :: [ImportDecl]
imports1 decls1 :: [Decl]
decls1)
(Hs.Module _head2 :: Maybe ModuleHead
_head2 _exports2 :: [ModulePragma]
_exports2 imports2 :: [ImportDecl]
imports2 decls2 :: [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 x :: [ImportDecl]
x y :: [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 x :: [Decl]
x y :: [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)
funcNamesBound :: Decl -> [Name]
funcNamesBound (Hs.FunBind ms :: [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 n :: Name
n _ _ _ <- [Match]
ms]
funcNamesBound _ = []
moduleProblems :: Hs.Module -> Maybe [Char]
moduleProblems :: Module -> Maybe String
moduleProblems (Hs.Module _head :: Maybe ModuleHead
_head pragmas :: [ModulePragma]
pragmas _imports :: [ImportDecl]
_imports _decls :: [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 "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 "\"Trustworthy\" language pragma is set"
| Bool
otherwise = Maybe String
forall a. Maybe a
Nothing
where
safe :: Name
safe = String -> Name
Hs.name "Safe"
trusted :: Name
trusted = String -> Name
Hs.name "Trustworthy"
langs :: [Name]
langs = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Name]
ls | Hs.LanguagePragma ls :: [Name]
ls <- [ModulePragma]
pragmas ]
moveFile :: FilePath -> FilePath -> IO ()
moveFile :: String -> String -> IO ()
moveFile from :: String
from to :: String
to = do
String -> String -> IO ()
copyFile String
from String
to
String -> IO ()
removeFile String
from
comp :: MonadLB m => Hs.Module -> m String
comp :: Module -> m String
comp src :: Module
src = do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
writeFile ".L.hs" (Module -> String
forall a. Pretty a => a -> String
Hs.prettyPrint Module
src))
[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
[ ["-O", "-v0", "-c", "-Werror", "-fpackage-trust"]
, [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [["-trust", String
pkg] | String
pkg <- [String]
trusted]
, [".L.hs"]
]
String
ghc <- Config String -> m String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
ghcBinary
(c :: ExitCode
c, o' :: String
o',e' :: 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 "")
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 ".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 ".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 ".L.hs")
String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return "Error."
| Bool
otherwise -> do
String
l <- LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findLBFileForWriting "L.hs")
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
moveFile ".L.hs" String
l)
String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return "Defined."
(ee :: String
ee,[]) -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
ee
(_ ,ee :: 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 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
=='\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
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 "L.hs")
IO () -> m ()
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 :: 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 "Pristine.hs")
case Maybe String
p of
Nothing -> do
String
p <- LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findOrCreateLBFile "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 ("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
Nothing -> LB (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB (Maybe String)
findLBFileForReading "Pristine.hs.default")
p0 :: 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 p0 :: String
p0 -> do
String
p <- LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findLBFileForWriting "Pristine.hs")
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
copyFile String
p0 String
p)
_ -> () -> 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 p :: String
p -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
p
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 "L.hs")
case Maybe String
file of
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 "L.hs")
Just file :: String
file -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
file