    {-# 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 = return
            [ (command "run")
                { help = say "run <expr>. You have Haskell, 3 seconds and no IO. Go nuts!"
                , process = lim80 . runGHC
                }
            , (command "let")
                { aliases = ["define"] -- because @define always gets "corrected" to @undefine
                , help = say "let <x> = <e>. Add a binding"
                , process = lim80 . define
                }
            , (command "undefine")
                { help = say "undefine. Reset evaluator local bindings"
                , process = \String
    s ->
                    if String -> Bool
    forall a. [a] -> 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
    txt -> do
            b <- String -> Cmd (ModuleT () LB) Bool
    forall (m :: * -> *). MonadLB m => String -> m Bool
    isEval String
    txt
            when b (lim80 (runGHC (dropPrefix 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 :: forall (m :: * -> *). MonadLB m => String -> m Bool
    isEval String
    str = do
        prefixes <- Config [String] -> m [String]
    forall a. Config a -> m a
    forall (m :: * -> *) a. MonadConfig m => Config a -> m a
    getConfig Config [String]
    evalPrefixes
        return (prefixes `arePrefixesWithSpaceOf` 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 :: forall (m :: * -> *). MonadLB m => String -> m String
    runGHC String
    src = do
        load    <- m String
    forall (m :: * -> *). MonadLB m => m String
    findL_hs
        binary  <- getConfig muevalBinary
        exts    <- getConfig languageExts
        trusted <- getConfig trustedPackages
        (_,out,err) <- io (readProcessWithExitCode binary (args load src exts trusted) "")
        case (out,err) of
            ([],[]) -> String -> m String
    forall a. a -> m a
    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 a. a -> m a
    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 a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    o Bool -> Bool -> Bool
    && String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    e -> String
    "Terminated\n"
                    | String -> Bool
    forall a. [a] -> 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 :: forall (m :: * -> *). MonadLB m => String -> m String
    define [] = String -> m String
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    "Define what?"
    define String
    src = do
        exts <- Config [String] -> m [String]
    forall a. Config a -> m a
    forall (m :: * -> *) a. MonadConfig m => Config a -> m a
    getConfig Config [String]
    languageExts
        let mode = ParseMode
    Hs.defaultParseMode{ Hs.extensions = map Hs.classifyExtension exts }
        case Hs.parseModuleWithMode mode (decodeString src) of
            Hs.ParseOk Module
    srcModule -> do
                l <- m String
    forall (m :: * -> *). MonadLB m => m String
    findL_hs
                res <- io (Hs.parseFile l)
                case res of
                    Hs.ParseFailed SrcLoc
    loc String
    err -> String -> m String
    forall a. a -> m a
    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 a. a -> m a
    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 a. a -> m a
    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 a. Eq a => a -> [a] -> 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 :: forall (m :: * -> *). MonadLB m => 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.
        trusted <- Config [String] -> m [String]
    forall a. Config a -> m a
    forall (m :: * -> *) a. MonadConfig m => Config a -> m a
    getConfig Config [String]
    trustedPackages
        let 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"]
                ]
        ghc <- getConfig ghcBinary
        (c, o',e') <- io (readProcessWithExitCode ghc ghcArgs "")
        -- cleanup, 'try' because in case of error the files are not generated
        _ <- io (try (removeFile ".L.hi") :: IO (Either SomeException ()))
        _ <- io (try (removeFile ".L.o")  :: IO (Either SomeException ()))

        case (mungeEnc o', mungeEnc 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 a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    "Error."
                    | Bool
    otherwise -> do
                        l <- LB String -> m String
    forall a. LB a -> m a
    forall (m :: * -> *) a. MonadLB m => LB a -> m a
    lb (String -> LB String
    findLBFileForWriting String
    "L.hs")
                        io (moveFile ".L.hs" l)
                        return "Defined."
            (String
    ee,[]) -> String -> m String
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    ee
            (String
    _ ,String
    ee) -> String -> m String
    forall a. a -> m a
    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 :: forall (m :: * -> *). MonadLB m => m ()
    resetL_hs = do
        p <- m String
    forall (m :: * -> *). MonadLB m => m String
    findPristine_hs
        l <- lb (findLBFileForWriting "L.hs")
        io (copyFile p 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 :: forall (m :: * -> *). MonadLB m => m String
    findPristine_hs = do
        p <- LB (Maybe String) -> m (Maybe String)
    forall a. LB a -> m a
    forall (m :: * -> *) a. MonadLB m => LB a -> m a
    lb (String -> LB (Maybe String)
    findLBFileForReading String
    "Pristine.hs")
        case p of
            Maybe String
    Nothing -> do
                p <- LB String -> m String
    forall a. LB a -> m a
    forall (m :: * -> *) a. MonadLB m => LB a -> m a
    lb (String -> LB String
    findOrCreateLBFile String
    "Pristine.hs")
                p0 <- lb (findLBFileForReading ("Pristine.hs." ++ show __GLASGOW_HASKELL__))
                p0 <- case p0 of
                    Maybe String
    Nothing -> LB (Maybe String) -> m (Maybe String)
    forall a. LB a -> m a
    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 a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe String
    p0
                case p0 of
                    Just String
    p0 -> do
                        p <- LB String -> m String
    forall a. LB a -> m a
    forall (m :: * -> *) a. MonadLB m => LB a -> m a
    lb (String -> LB String
    findLBFileForWriting String
    "Pristine.hs")
                        io (copyFile p0 p)
                    Maybe String
    _ -> () -> m ()
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                return p
            Just String
    p -> String -> m String
    forall a. a -> m a
    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 :: forall (m :: * -> *). MonadLB m => m String
    findL_hs = do
        file <- LB (Maybe String) -> m (Maybe String)
    forall a. LB a -> m a
    forall (m :: * -> *) a. MonadLB m => LB a -> m a
    lb (String -> LB (Maybe String)
    findLBFileForReading String
    "L.hs")
        case file of
            -- if L.hs
            Maybe String
    Nothing -> m ()
    forall (m :: * -> *). MonadLB m => m ()
    resetL_hs m () -> m String -> m String
    forall a b. m a -> m b -> m b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> LB String -> m String
    forall a. LB a -> m a
    forall (m :: * -> *) a. MonadLB m => LB a -> m a
    lb (String -> LB String
    findOrCreateLBFile String
    "L.hs")
            Just String
    file -> String -> m String
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    file