{-# 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 "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"] -- because @define always gets "corrected" to @undefine
            , 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 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 "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)

-- 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  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)

        -- 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 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

-- It parses. then add it to a temporary L.hs and typecheck
comp :: MonadLB m => Hs.Module -> m String
comp :: Module -> m String
comp src :: 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 ".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
            [ ["-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 "")
    -- 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 ".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

------------------------------
-- 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 "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 "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

-- 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 "L.hs")
    case Maybe String
file of
        -- if L.hs
        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