├── .gitignore ├── Backend.hs ├── Cache.hs ├── Config.hs ├── Format.hs ├── Frontend.hs ├── LICENSE ├── Main.hs ├── Parser.hs ├── Pastebin.hs ├── Setup.hs ├── Types.hs ├── UpdateChan.hs ├── discord-eval.cabal └── docker ├── Dockerfile ├── buildghc └── ghc-patch │ ├── 0001-Wakeup.patch │ ├── 0002-Don-t-display-user-input-in-t-k.patch │ └── 0003-Fix-disable-large-address-space.patch ├── eval.yaml ├── gcc ├── jail.conf └── runghci ├── init └── runghci /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | *.dyn_hi 4 | *.dyn_o 5 | eval.conf 6 | -------------------------------------------------------------------------------- /Backend.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} 2 | module Backend where 3 | 4 | import Calamity hiding (Embed) 5 | import Control.Concurrent 6 | import Control.Exception hiding (bracket, bracket_) 7 | import Control.Exception qualified as E 8 | import Control.Monad 9 | import Control.Monad.IO.Class 10 | import Data.ByteString (ByteString) 11 | import Data.ByteString qualified as BS 12 | import Data.Foldable 13 | import Data.List.NonEmpty qualified as NE 14 | import Data.Map qualified as M 15 | import Data.Text qualified as T 16 | import Data.Text.Encoding qualified as T 17 | import Data.Traversable 18 | import Df1 hiding (Message) 19 | import DiPolysemy 20 | import Network.HTTP.Client hiding (Request) 21 | import Network.HTTP.Client.TLS 22 | import Polysemy 23 | import Polysemy.Error 24 | import Polysemy.Reader 25 | import Polysemy.Resource 26 | import System.IO 27 | import System.Process hiding (runCommand) 28 | import TextShow 29 | 30 | import Config 31 | import Format 32 | import Types 33 | import UpdateChan 34 | 35 | communicateProc 36 | :: Members '[Resource, Embed IO, Reader EvalConfig, LogEff] r 37 | => CmdLine -> ByteString -> Sem r ByteString 38 | communicateProc (cmd NE.:| args) input = do 39 | (rdIn, wrIn) <- liftIO createPipe 40 | (rdOut, wrOut) <- liftIO createPipe 41 | bracket 42 | do 43 | debug $ "process: " <> showt cmd <> " " <> showt args 44 | liftIO $ createProcess (proc cmd args) 45 | { std_in = UseHandle rdIn 46 | , std_out = UseHandle wrOut 47 | , std_err = UseHandle wrOut 48 | , close_fds = True 49 | } 50 | (\(_, _, _, p) -> do 51 | code <- liftIO $ waitForProcess p 52 | debug $ "exit: " <> showt code) 53 | \_ -> do 54 | liftIO do 55 | hClose rdIn 56 | hClose wrOut 57 | void $ forkIO $ E.finally (BS.hPut wrIn input) (hClose wrIn) 58 | config :: EvalConfig <- ask 59 | liftIO $ E.finally (BS.hGet rdOut config.pastebinSizeLimit) (hClose rdOut) 60 | 61 | runCmd 62 | :: Members '[Resource, Embed IO, Reader EvalConfig, LogEff] r 63 | => (Int, Command) -> Sem r ByteString 64 | runCmd (i, cmd) = push (segment $ "C" <> showt i) do 65 | config :: EvalConfig <- ask 66 | case cmd of 67 | Reset name 68 | | Just LiveState { resetCommand } <- M.lookup name config.interpreters 69 | -> communicateProc resetCommand "" 70 | EvalLine name txt 71 | | Just LiveState { runCommand } <- M.lookup name config.interpreters 72 | -> communicateProc runCommand (T.encodeUtf8 txt) 73 | EvalBlock name txt 74 | | Just LiveState { runCommand } <- M.lookup name config.interpreters 75 | -> BS.concat <$> for (T.lines txt) 76 | (communicateProc runCommand . (<> "\n") . T.encodeUtf8) 77 | _ -> pure mempty 78 | 79 | backend 80 | :: Members '[Resource, Final IO, Embed IO, Reader EvalConfig, LogEff] r 81 | => UpdateChan (Snowflake Message) Request -> Sem r () 82 | backend chan = bracket_ 83 | (info @String "Starting backend thread") 84 | (info @String "Closing backend thread") 85 | $ push "backend" do 86 | mgr <- liftIO $ newManager tlsManagerSettings 87 | runReader mgr $ forever do 88 | debug @String "Waiting" 89 | (msgId, req NE.:| oldReqs) <- readUpdateChan chan 90 | push (segment $ showt msgId) do 91 | for_ oldReqs \oldReq -> liftIO $ putMVar oldReq.response Nothing 92 | var <- liftIO newEmptyMVar 93 | liftIO $ putMVar req.response $ Just var 94 | 95 | eTxt <- runError $ fromExceptionSem $ 96 | fold <$> for req.commands \commands -> do 97 | config :: EvalConfig <- ask 98 | outputs <- filter (not . BS.null) 99 | <$> traverse runCmd (zip [0..] $ NE.toList commands) 100 | formatResults config.msgSizeLimit outputs 101 | 102 | liftIO $ putMVar var $ case eTxt of 103 | Right txt -> txt 104 | Left (exc :: SomeException) -> showt exc 105 | -------------------------------------------------------------------------------- /Cache.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} 2 | module Cache where 3 | 4 | import Calamity hiding (Embed, Member) 5 | import Control.Monad.IO.Class 6 | import Data.Default 7 | import Data.List.NonEmpty (NonEmpty) 8 | import Data.Map.Strict (Map) 9 | import Data.Map.Strict qualified as M 10 | import Data.Set (Set) 11 | import Data.Set qualified as S 12 | import Data.Time 13 | import Polysemy 14 | import Polysemy.AtomicState 15 | import Polysemy.Reader 16 | 17 | import Config 18 | import Types 19 | 20 | data ActiveMessage = ActiveMessage 21 | { id :: !(Snowflake Message) 22 | , updated :: !UTCTime 23 | , channel :: !(Snowflake Channel) 24 | , commands :: !(Maybe (NonEmpty Command)) 25 | , response :: !(Maybe (Snowflake Message)) 26 | } 27 | 28 | deriving Show 29 | 30 | data EvalState = EvalState 31 | { messageById :: !(Map (Snowflake Message) ActiveMessage) 32 | , messageByAge :: !(Set (UTCTime, Snowflake Message)) 33 | } 34 | 35 | instance Default EvalState where 36 | def = EvalState 37 | { messageById = M.empty 38 | , messageByAge = S.empty 39 | } 40 | 41 | pruneMessages 42 | :: Members '[Embed IO, Reader EvalConfig, AtomicState EvalState] r => Sem r () 43 | pruneMessages = do 44 | config <- ask 45 | now <- liftIO getCurrentTime 46 | atomicModify' \state -> let 47 | (pruned, messageByAge) = S.spanAntitone 48 | (\(t, _) -> now `diffUTCTime` t > secondsToNominalDiffTime 49 | (fromIntegral config.forgetAfterSeconds)) 50 | state.messageByAge 51 | messageById = state.messageById `M.withoutKeys` S.map snd pruned 52 | in state 53 | { messageByAge 54 | , messageById 55 | } 56 | 57 | lookupMessage 58 | :: Member (AtomicState EvalState) r 59 | => Snowflake Message -> Sem r (Maybe ActiveMessage) 60 | lookupMessage mId = M.lookup mId . (.messageById) <$> atomicGet 61 | 62 | upsertMessage 63 | :: Member (AtomicState EvalState) r => ActiveMessage -> Sem r () 64 | upsertMessage am = atomicModify' \state -> 65 | let 66 | (mOldAm, messageById) = M.insertLookupWithKey 67 | (\_ new _old -> new) am.id am state.messageById 68 | messageByAge = S.insert (am.updated, am.id) case mOldAm of 69 | Nothing -> state.messageByAge 70 | Just oldAm -> S.delete (oldAm.updated, oldAm.id) state.messageByAge 71 | in state 72 | { messageById 73 | , messageByAge 74 | } 75 | 76 | deleteMessage 77 | :: Member (AtomicState EvalState) r => Snowflake Message -> Sem r () 78 | deleteMessage mId = atomicModify' \state -> 79 | case M.lookup mId state.messageById of 80 | Just am -> state 81 | { messageById = M.delete mId state.messageById 82 | , messageByAge = S.delete (am.updated, am.id) state.messageByAge 83 | } 84 | Nothing -> state 85 | -------------------------------------------------------------------------------- /Config.hs: -------------------------------------------------------------------------------- 1 | module Config where 2 | 3 | import Calamity.Types 4 | import Data.Aeson 5 | import Data.List.NonEmpty (NonEmpty) 6 | import Data.Map (Map) 7 | import Data.Set (Set) 8 | import Data.Text (Text) 9 | import GHC.Generics (Generic) 10 | 11 | newtype InterpreterName = InterpreterName Text 12 | deriving newtype (Eq, Ord, Show, FromJSONKey, ToJSONKey, FromJSON, ToJSON) 13 | 14 | newtype Blocks = Blocks Int 15 | deriving newtype (FromJSON, ToJSON) 16 | 17 | type CmdLine = NonEmpty FilePath 18 | 19 | data Interpreter 20 | = LiveState 21 | { runCommand :: !CmdLine 22 | , resetCommand :: !CmdLine 23 | } 24 | | IndexedState 25 | { runCommand :: !CmdLine 26 | , pruneCommand :: !CmdLine 27 | } 28 | deriving stock (Generic) 29 | deriving anyclass (FromJSON, ToJSON) 30 | 31 | data Wrapper = Wrapper 32 | { prefix :: !(Maybe Text) 33 | , suffix :: !(Maybe Text) 34 | , stripControl :: !(Maybe Bool) 35 | , interpreter :: !InterpreterName 36 | } 37 | deriving stock (Generic) 38 | deriving anyclass (FromJSON, ToJSON) 39 | 40 | data EvalConfig = EvalConfig 41 | { logFile :: !FilePath 42 | , token :: !Text 43 | , testGuilds :: !(Set (Snowflake Guild)) 44 | , isTest :: !Bool 45 | , forgetAfterSeconds :: !Int 46 | , blockCountLimit :: !Blocks 47 | , msgSizeLimit :: !Int 48 | , pastebinSizeLimit :: !Int 49 | , reactWait :: !RawEmoji 50 | , reactCancel :: !RawEmoji 51 | , emptyOutput :: !Text 52 | , interpreters :: !(Map InterpreterName Interpreter) 53 | , defaultInline :: Wrapper 54 | , defaultCodeBlock :: Wrapper 55 | , codeBlockLanguages :: !(Map Text Wrapper) 56 | } 57 | deriving stock (Generic) 58 | deriving anyclass (FromJSON, ToJSON) 59 | 60 | configFile :: FilePath 61 | configFile = "eval.yaml" 62 | -------------------------------------------------------------------------------- /Format.hs: -------------------------------------------------------------------------------- 1 | module Format where 2 | 3 | import Control.Arrow 4 | import Data.ByteString (ByteString) 5 | import Data.Char 6 | import Data.List 7 | import Data.Text (Text) 8 | import Data.Text qualified as T 9 | import Data.Text.Encoding qualified as T 10 | import Data.Text.Encoding.Error qualified as T hiding (replace) 11 | import Data.Ord 12 | import Polysemy 13 | 14 | import Pastebin 15 | 16 | formatCodeBlock :: ByteString -> Text 17 | formatCodeBlock bs 18 | | txt <- T.decodeUtf8With T.lenientDecode bs 19 | , txt' <- T.replace "``" "``\x200D" $ T.filter goodChar txt 20 | = T.concat 21 | [ "```ansi\n" 22 | , txt' 23 | , if "`" `T.isSuffixOf` txt' then "\x200D" else "" 24 | , if T.null txt' then "\n" else "" 25 | , "```" 26 | ] 27 | where 28 | goodChar = \case 29 | '\n' -> True 30 | '\x1B' -> True 31 | c -> not $ isControl c 32 | 33 | formatPaste :: Text -> Text 34 | formatPaste link = T.concat ["<", link, ">\n"] 35 | 36 | formatResults :: PasteC r => Int -> [ByteString] -> Sem r Text 37 | formatResults maxChars results = go [] $ 38 | sortOn (Down . T.length . snd . snd) $ 39 | zip [0 :: Int ..] $ (id &&& formatCodeBlock) <$> results 40 | where 41 | totalSize pasted blocks = 42 | sum (T.length . snd <$> pasted) 43 | + sum (T.length . snd . snd <$> blocks) 44 | 45 | go pasted blocks 46 | | totalSize pasted blocks > maxChars 47 | , (i, (result, _)):bs <- blocks 48 | = do 49 | link <- pastebin result 50 | go ((i, formatPaste link):pasted) bs 51 | | otherwise 52 | = pure $ T.concat $ snd <$> (sortOn fst pasted ++ (second snd <$> blocks)) 53 | -------------------------------------------------------------------------------- /Frontend.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} 2 | module Frontend where 3 | 4 | import Calamity hiding (Embed, Member) 5 | import Calamity qualified as CreateMessageOptions (CreateMessageOptions(..)) 6 | import Calamity.Cache.Eff 7 | import Calamity.Internal.Utils (MaybeNull(..)) 8 | import Calamity.Types.Model.Channel.UpdatedMessage 9 | import Control.Concurrent.MVar 10 | import Control.Monad 11 | import Control.Monad.IO.Class 12 | import Data.Default 13 | import Data.Foldable 14 | import Data.List.NonEmpty (NonEmpty) 15 | import Data.List.NonEmpty qualified as NE 16 | import Data.Maybe 17 | import Data.Set qualified as S 18 | import Data.Text (Text) 19 | import Data.Text qualified as T 20 | import Data.Time 21 | import Df1 hiding (Message) 22 | import DiPolysemy 23 | import Polysemy 24 | import Polysemy.AtomicState 25 | import Polysemy.Reader 26 | import Polysemy.Resource 27 | import TextShow 28 | 29 | import Cache 30 | import Cache qualified as ActiveMessage (ActiveMessage(..)) 31 | import Config 32 | import Parser 33 | import Types 34 | import UpdateChan 35 | 36 | cachedMessage 37 | :: Members [Embed IO, Reader EvalConfig, AtomicState EvalState, CacheEff] r 38 | => Message -> Sem r (Maybe ActiveMessage) 39 | cachedMessage msg = do 40 | config :: EvalConfig <- ask 41 | case (msg.guildID, msg.author) of 42 | (Just gId, User' _) 43 | | config.isTest == gId `S.member` config.testGuilds -> do 44 | commands <- parseRequest msg.mentions msg.content 45 | let 46 | am = ActiveMessage 47 | { id = msg.id 48 | , updated = msg.timestamp 49 | , channel = msg.channelID 50 | , commands 51 | , response = Nothing 52 | } 53 | upsertMessage am 54 | pruneMessages 55 | pure $ Just am 56 | _ -> pure Nothing 57 | 58 | parseRequest 59 | :: Members '[Reader EvalConfig, CacheEff] r 60 | => [User] -> Text -> Sem r (Maybe (NonEmpty Command)) 61 | parseRequest [] _ = pure Nothing 62 | parseRequest mentions content = getBotUser >>= \case 63 | Just me | any (\m -> m.id == me.id) mentions 64 | -> NE.nonEmpty <$> parseMessage content 65 | _ -> pure Nothing 66 | 67 | processChangedCommands 68 | :: (BotC r, Members [Reader EvalConfig, AtomicState EvalState] r) 69 | => UpdateChan (Snowflake Message) Request 70 | -> ActiveMessage 71 | -> Sem r () 72 | processChangedCommands chan am = do 73 | response <- liftIO newEmptyMVar 74 | working <- writeUpdateChan chan am.id Request 75 | { commands = am.commands 76 | , response 77 | } 78 | 79 | case am.commands of 80 | Nothing -> for_ am.response \respId -> do 81 | void $ invoke $ DeleteMessage am.channel respId 82 | upsertMessage am { ActiveMessage.response = Nothing } 83 | pruneMessages 84 | debug $ "Deleted previous response: " <> showt respId 85 | 86 | Just _ -> do 87 | config :: EvalConfig <- ask 88 | if working 89 | then do 90 | debug @String "starting imediately" 91 | void $ invoke $ TriggerTyping am.channel 92 | else do 93 | debug @String "queued" 94 | void $ invoke $ CreateReaction am.channel am.id config.reactWait 95 | 96 | mVar <- liftIO (takeMVar response) 97 | case mVar of 98 | Nothing -> debug @String "Overridden by another request" 99 | Just var -> do 100 | unless working $ void $ invoke $ 101 | DeleteOwnReaction am.channel am.id config.reactWait 102 | content <- liftIO (takeMVar var) 103 | debug $ "Got response: " <> showt content 104 | 105 | lookupMessage am.id >>= traverse_ \am' -> case am'.response of 106 | Nothing -> do 107 | invoke $ CreateMessage am'.channel def 108 | { CreateMessageOptions.content = Just 109 | if T.null content then config.emptyOutput else content 110 | } 111 | >>= \case 112 | Right respMsg -> do 113 | upsertMessage am' { ActiveMessage.response = Just respMsg.id } 114 | pruneMessages 115 | debug $ "Responded with: " <> showt respMsg.id 116 | Left _ -> pure () 117 | Just respId -> do 118 | void $ invoke $ EditMessage am'.channel respId $ 119 | editMessageContent $ Just 120 | if T.null content then config.emptyOutput else content 121 | debug $ "Updated previous response: " <> showt respId 122 | 123 | onMessageCreate 124 | :: (BotC r, Members '[Reader EvalConfig, AtomicState EvalState] r) 125 | => UpdateChan (Snowflake Message) Request -> Message -> Sem r () 126 | onMessageCreate chan msg = cachedMessage msg >>= traverse_ \am -> do 127 | debug $ "#" <> showt am.channel <> " : " 128 | <> showt (NE.toList <$> am.commands) 129 | processChangedCommands chan am 130 | 131 | onMessageUpdate 132 | :: (BotC r, Members '[Reader EvalConfig, AtomicState EvalState] r) 133 | => UpdateChan (Snowflake Message) Request 134 | -> UpdatedMessage 135 | -> UTCTime 136 | -> Sem r () 137 | onMessageUpdate chan msg timestamp = 138 | for_ msg.content \content -> for_ msg.mentions \mentions -> 139 | lookupMessage msg.id >>= traverse_ \am -> do 140 | commands <- parseRequest mentions content 141 | when (commands /= am.commands) do 142 | let 143 | am' = am 144 | { ActiveMessage.updated = timestamp 145 | , ActiveMessage.commands 146 | } 147 | upsertMessage am' 148 | pruneMessages 149 | processChangedCommands chan am' 150 | 151 | onMessageDelete 152 | :: (BotC r, Members '[Reader EvalConfig, AtomicState EvalState] r) 153 | => UpdateChan (Snowflake Message) Request 154 | -> Snowflake Message 155 | -> Sem r () 156 | onMessageDelete chan msgId = lookupMessage msgId >>= traverse_ \am -> 157 | when (isJust am.commands) do 158 | now <- liftIO getCurrentTime 159 | let 160 | am' = am 161 | { updated = now 162 | , ActiveMessage.commands = Nothing 163 | } 164 | upsertMessage am' 165 | pruneMessages 166 | processChangedCommands chan am' 167 | 168 | frontend 169 | :: (BotC r, Members '[Embed IO, Resource, Reader EvalConfig] r) 170 | => UpdateChan (Snowflake Message) Request -> Sem r () 171 | frontend chan = bracket_ 172 | (info @String "Starting frontend thread") 173 | (info @String "Closing frontend thread") 174 | $ void $ atomicStateToIO @EvalState def $ push "frontend" do 175 | void $ react @'MessageCreateEvt \(msg, _, _) -> 176 | push (segment $ showt msg.id) $ 177 | push (segment $ showt $ FromStringShow msg.timestamp) $ 178 | push "create" $ onMessageCreate chan msg 179 | void $ react @'RawMessageUpdateEvt \(msg, _, _) -> 180 | for_ msg.editedTimestamp $ \case 181 | WasNull -> pure () 182 | NotNull timestamp -> 183 | push (segment $ showt msg.id) $ 184 | push (segment $ showt $ FromStringShow timestamp) $ 185 | push "update" $ onMessageUpdate chan msg timestamp 186 | void $ react @'RawMessageDeleteEvt \msgId -> 187 | push (segment $ showt msgId) $ 188 | push "delete" $ onMessageDelete chan msgId 189 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, mniip 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of mniip nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} 2 | module Main where 3 | 4 | import Calamity.Cache.InMemory 5 | import Calamity hiding (Embed) 6 | import Calamity.Metrics.Noop 7 | import Control.Monad.IO.Class 8 | import Data.Yaml 9 | import Di qualified 10 | import DiPolysemy 11 | import Polysemy 12 | import Polysemy.Async 13 | import Polysemy.Reader 14 | import Polysemy.Resource 15 | 16 | import Config 17 | import Backend 18 | import Frontend 19 | import UpdateChan 20 | 21 | main :: IO () 22 | main = Di.new \di -> runFinal $ embedToFinal $ runDiToIO di $ 23 | asyncToIOFinal $ resourceToIOFinal $ 24 | liftIO (decodeFileEither configFile) >>= \case 25 | Left err -> critical $ prettyPrintParseException err 26 | Right (config :: EvalConfig) -> runReader config do 27 | chan <- newUpdateChan 28 | bracket (async $ backend chan) cancel \_ -> 29 | runMetricsNoop $ runCacheInMemoryNoMsg $ do 30 | tk <- asks (.token) 31 | runBotIO (BotToken tk) defaultIntents $ 32 | frontend chan 33 | >>= \case 34 | Just (StartupError err) -> critical err 35 | Nothing -> pure () 36 | -------------------------------------------------------------------------------- /Parser.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} 2 | module Parser where 3 | 4 | import Control.Monad 5 | import Data.Char 6 | import Data.Map qualified as M 7 | import Data.Maybe 8 | import Data.Text (Text) 9 | import Data.Text qualified as T 10 | import Data.Void 11 | import Polysemy 12 | import Polysemy.Reader 13 | import Text.Megaparsec 14 | import Text.Megaparsec.Char 15 | 16 | import Config 17 | import Types 18 | 19 | codeBlock :: Parsec Void Text (Maybe Text, Text) 20 | codeBlock = do 21 | void $ string "```" 22 | choice 23 | [ try do 24 | language <- takeWhile1P Nothing \case 25 | '+' -> True 26 | '-' -> True 27 | '.' -> True 28 | c -> isAscii c && isAlphaNum c 29 | void $ takeWhile1P Nothing (== '\n') 30 | (Just language,) <$> finish 31 | , do 32 | void $ takeWhileP Nothing (== '\n') 33 | (Nothing,) <$> finish 34 | ] 35 | where 36 | finish = T.concat <$> someTill 37 | (takeWhile1P Nothing (`notElem` ['\n', '`']) 38 | <|> string "\n" <|> string "`") 39 | (try $ takeWhileP Nothing (== '\n') *> string "```") 40 | 41 | inlineCode :: Parsec Void Text Text 42 | inlineCode = choice 43 | [ try do 44 | void $ string "``" 45 | (content, end) <- manyTill_ 46 | (takeWhile1P Nothing (/= '`') <|> string "`") 47 | (try $ takeWhile1P Nothing (/= '`') 48 | <* string "``" <* notFollowedBy (string "`")) 49 | pure $ stripLeft $ stripRight $ T.concat content <> end 50 | , do 51 | void $ string "`" 52 | (content, end) <- manyTill_ 53 | (takeWhile1P Nothing (/= '`') <|> string "`") 54 | (try $ takeWhile1P Nothing (/= '`') 55 | <* string "`" <* notFollowedBy (string "`")) 56 | pure $ stripLeft $ stripRight $ T.concat content <> end 57 | ] 58 | where 59 | stripLeft (T.stripPrefix " " -> Just t) | "`" `T.isPrefixOf` t = t 60 | stripLeft t = t 61 | stripRight (T.stripSuffix " " -> Just t) | "`" `T.isSuffixOf` t = t 62 | stripRight t = t 63 | 64 | parseMessage 65 | :: Member (Reader EvalConfig) r => Text -> Sem r [Command] 66 | parseMessage input = do 67 | config <- ask 68 | let 69 | Blocks maxBlocks = config.blockCountLimit 70 | 71 | parser = take maxBlocks . concat <$> many do 72 | choice 73 | [ try do 74 | (mLang, content) <- codeBlock 75 | let 76 | wrapper = fromMaybe config.defaultCodeBlock 77 | (mLang >>= (`M.lookup` config.codeBlockLanguages)) 78 | pure [EvalBlock wrapper.interpreter $ wrap wrapper content] 79 | , try do 80 | content <- inlineCode 81 | let wrapper = config.defaultInline 82 | pure [EvalLine wrapper.interpreter $ wrap wrapper content] 83 | , try do 84 | void $ string "!reset" 85 | mLang <- optional $ try $ space1 *> takeWhileP Nothing isAlpha 86 | pure [Reset $ 87 | maybe config.defaultInline.interpreter InterpreterName mLang] 88 | , [] <$ anySingle <* takeWhileP Nothing (`notElem` ['!', '`']) 89 | ] 90 | 91 | wrap :: Wrapper -> Text -> Text 92 | wrap wrapper content = addPrefix $ addSuffix $ stripControl content 93 | where 94 | addPrefix = case wrapper.prefix of 95 | Just p -> (p <>) 96 | _ -> id 97 | addSuffix = case wrapper.suffix of 98 | Just s -> (<> s) 99 | _ -> id 100 | stripControl = case wrapper.stripControl of 101 | Just True -> T.map \case 102 | c | isControl c -> ' ' 103 | | otherwise -> c 104 | _ -> id 105 | 106 | pure $ case parse (parser <* eof) "" input of 107 | Left errs -> error $ errorBundlePretty errs 108 | Right blocks -> blocks 109 | -------------------------------------------------------------------------------- /Pastebin.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} 2 | module Pastebin where 3 | 4 | import Calamity.Types.LogEff 5 | import Control.Monad.IO.Class 6 | import Data.ByteString (ByteString) 7 | import Data.ByteString qualified as BS 8 | import Data.Text (Text) 9 | import Data.Text.Encoding qualified as T 10 | import Data.Text.Encoding.Error qualified as T 11 | import DiPolysemy hiding (error) 12 | import Network.HTTP.Client 13 | import Network.HTTP.Types 14 | import Polysemy 15 | import Polysemy.Reader 16 | import TextShow 17 | import Web.FormUrlEncoded 18 | 19 | type PasteC r = Members [Embed IO, Reader Manager, LogEff] r 20 | 21 | pastebin :: PasteC r => ByteString -> Sem r Text 22 | pastebin bs = push "paste" do 23 | mgr <- ask 24 | let 25 | req = "POST https://paste.tomsmeding.com/paste" 26 | { requestHeaders = [("Content-Type", "application/x-www-form-urlencoded")] 27 | , requestBody = RequestBodyLBS $ urlEncodeForm $ toForm 28 | [ ("name1" :: String, "") 29 | , ("code1", T.decodeUtf8With T.lenientDecode bs) 30 | , ("expire", "day") 31 | ] 32 | , redirectCount = 0 33 | } 34 | debug $ "Pasting " <> showt (BS.length bs) <> " bytes" 35 | resp <- liftIO $ httpNoBody req mgr 36 | debug $ "Got: " <> showt (FromStringShow resp) 37 | if responseStatus resp /= seeOther303 38 | then error $ "Unexpected response status: " ++ show (responseStatus resp) 39 | else case lookup "Location" $ responseHeaders resp of 40 | Nothing -> error "No location header" 41 | Just loc -> pure $ "https://paste.tomsmeding.com" 42 | <> T.decodeUtf8With T.lenientDecode loc 43 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Types.hs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | import Control.Concurrent 4 | import Data.List.NonEmpty (NonEmpty) 5 | import Data.Text (Text) 6 | import TextShow 7 | 8 | import Config 9 | 10 | data Command 11 | = Reset InterpreterName 12 | | EvalLine InterpreterName Text 13 | | EvalBlock InterpreterName Text 14 | deriving stock (Eq, Show) 15 | deriving TextShow via FromStringShow Command 16 | 17 | data Request = Request 18 | { commands :: !(Maybe (NonEmpty Command)) 19 | , response :: !(MVar (Maybe (MVar Text))) 20 | } 21 | -------------------------------------------------------------------------------- /UpdateChan.hs: -------------------------------------------------------------------------------- 1 | module UpdateChan 2 | ( UpdateChan 3 | , newUpdateChan 4 | , writeUpdateChan 5 | , readUpdateChan 6 | ) where 7 | 8 | import Control.Concurrent.STM 9 | import Control.Exception 10 | import Control.Monad.IO.Class 11 | import Data.Bifunctor 12 | import Data.List.NonEmpty (NonEmpty) 13 | import Data.List.NonEmpty qualified as NE 14 | import Data.Map.Strict (Map) 15 | import Data.Map.Strict qualified as M 16 | import Data.Maybe 17 | import Data.Sequence (Seq) 18 | import Data.Sequence qualified as Seq 19 | 20 | data UpdateChanData k v = UpdateChanData 21 | { keys :: !(Map k Int) 22 | , keyOffset :: !Int 23 | , values :: !(Seq (k, NonEmpty v)) 24 | } 25 | deriving stock Show 26 | 27 | doRead :: Ord k => TVar (UpdateChanData k v) -> STM (k, NonEmpty v) 28 | doRead var = do 29 | state <- readTVar var 30 | case Seq.viewl state.values of 31 | Seq.EmptyL -> retry 32 | (k, vs) Seq.:< values -> do 33 | writeTVar var UpdateChanData 34 | { keys = M.delete k state.keys 35 | , keyOffset = state.keyOffset - 1 36 | , values 37 | } 38 | pure (k, vs) 39 | 40 | doWrite :: Ord k => TVar (UpdateChanData k v) -> k -> v -> STM Bool 41 | doWrite var k v = stateTVar var \state -> 42 | let 43 | (mi, keys) = M.insertLookupWithKey (\_ _new old -> old) k 44 | (Seq.length state.values - state.keyOffset) state.keys 45 | values = case mi of 46 | Nothing -> state.values Seq.|> (k, NE.singleton v) 47 | Just i -> Seq.adjust (second (v NE.<|)) (i + state.keyOffset) state.values 48 | in 49 | ( isNothing mi 50 | , UpdateChanData 51 | { keys 52 | , keyOffset = state.keyOffset 53 | , values 54 | } 55 | ) 56 | 57 | -- | A queue that removes duplicates based on keys and tells whether a push -- has resulted in an immediate pop in another thread. 58 | data UpdateChan k v = UpdateChan 59 | { state :: !(TVar (UpdateChanData k v)) 60 | , demand :: !(TVar Int) 61 | } 62 | 63 | newUpdateChan :: MonadIO m => m (UpdateChan k v) 64 | newUpdateChan = liftIO do 65 | state <- newTVarIO UpdateChanData 66 | { keys = M.empty 67 | , keyOffset = 0 68 | , values = Seq.empty 69 | } 70 | demand <- newTVarIO 0 71 | pure UpdateChan{..} 72 | 73 | -- | Wait if the queue is empty, and then retrieve the least recently pushed 74 | -- key along with the list of values pushed to it, starting from most recent. 75 | readUpdateChan :: (Ord k, MonadIO m) => UpdateChan k v -> m (k, NonEmpty v) 76 | readUpdateChan chan = liftIO $ bracket acquire release 77 | \committed -> atomically $ doRead chan.state <* writeTVar committed True 78 | where 79 | acquire = atomically do 80 | modifyTVar' chan.demand succ 81 | newTVar False 82 | release committed = atomically $ readTVar committed >>= \case 83 | True -> pure () 84 | False -> modifyTVar' chan.demand pred 85 | 86 | -- | Add a key-value pair to the end of the queue, unless the queue already 87 | -- contains a not yet retrieved pair with the same key, in which case the value 88 | -- is added to that location in the queue. 89 | -- 90 | -- If by the time this function is entered, some other thread is already waiting 91 | -- in 'readUpdateChan' to retrieve the value we just pushed, return 'True'. 92 | -- 93 | -- If by the time this function is exited, no other thread is yet waiting in 94 | -- 'readUpdateChan' to retrieve the value we just pushed, return 'False'. 95 | -- 96 | -- In all other cases (if there is a race), the return value is unspecified. 97 | writeUpdateChan :: (Ord k, MonadIO m) => UpdateChan k v -> k -> v -> m Bool 98 | writeUpdateChan chan k v = liftIO $ atomically do 99 | b <- doWrite chan.state k v 100 | stateTVar chan.demand (\n -> (n > 0, n - if b then 1 else 0)) 101 | -------------------------------------------------------------------------------- /discord-eval.cabal: -------------------------------------------------------------------------------- 1 | name: discord-eval 2 | version: 0.1.0.0 3 | synopsis: A frontend for the Eval bot on Discord 4 | description: A frontend for the EVal bot on Dicosrd. 5 | license: BSD3 6 | license-file: LICENSE 7 | author: mniip 8 | maintainer: mniip@mniip.com 9 | copyright: (C) 2019-2023 mniip 10 | category: Development 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | 14 | executable discord-eval 15 | main-is: Main.hs 16 | other-modules: Backend 17 | , Cache 18 | , Config 19 | , Format 20 | , Frontend 21 | , Parser 22 | , Pastebin 23 | , Types 24 | , UpdateChan 25 | build-depends: base == 4.* 26 | , aeson 27 | , bytestring 28 | , calamity 29 | , containers 30 | , data-default 31 | , df1 32 | , di 33 | , di-polysemy 34 | , http-api-data 35 | , http-client 36 | , http-client-tls 37 | , http-types 38 | , megaparsec 39 | , text 40 | , text-show 41 | , polysemy 42 | , polysemy-plugin 43 | , process 44 | , stm 45 | , time 46 | , yaml 47 | default-language: Haskell2010 48 | default-extensions: BlockArguments 49 | , ConstraintKinds 50 | , DataKinds 51 | , DeriveAnyClass 52 | , DeriveGeneric 53 | , DerivingVia 54 | , FlexibleContexts 55 | , GADTs 56 | , GeneralizedNewtypeDeriving 57 | , ImportQualifiedPost 58 | , LambdaCase 59 | , NamedFieldPuns 60 | , NoFieldSelectors 61 | , OverloadedRecordDot 62 | , OverloadedStrings 63 | , RecordWildCards 64 | , ScopedTypeVariables 65 | , TupleSections 66 | , TypeApplications 67 | , ViewPatterns 68 | ghc-options: -Wall 69 | -------------------------------------------------------------------------------- /docker/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM debian:11-slim 2 | 3 | COPY buildghc /buildghc 4 | 5 | RUN apt-get update && apt-get install -y \ 6 | autoconf \ 7 | build-essential \ 8 | curl \ 9 | debootstrap \ 10 | g++ \ 11 | gcc \ 12 | git \ 13 | libgmp-dev \ 14 | libncurses-dev \ 15 | python3 \ 16 | zlib1g-dev && \ 17 | debootstrap --variant=minbase --include=libgmp-dev bullseye /sandbox/ && \ 18 | rmdir /sandbox/boot /sandbox/home /sandbox/media /sandbox/mnt /sandbox/opt /sandbox/srv && \ 19 | rm -r /sandbox/dev /sandbox/etc /sandbox/proc /sandbox/root /sandbox/run /sandbox/sys /sandbox/var && \ 20 | \ 21 | curl https://downloads.haskell.org/~ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 -o /ghcup && \ 22 | chmod +x /ghcup && \ 23 | /ghcup install ghc 9.2.8 && \ 24 | /ghcup install cabal 3.10.1.0 && \ 25 | export CABAL_DIR=/buildghc/ && \ 26 | export CABAL="$(/ghcup whereis cabal 3.10.1.0)" && \ 27 | export GHC="$(/ghcup whereis ghc 9.2.8)" && \ 28 | "$CABAL" update &&\ 29 | "$CABAL" install alex happy -w "$GHC" --installdir=/buildghc/ && \ 30 | git clone https://gitlab.haskell.org/ghc/ghc.git --branch ghc-9.6.2-release --depth 1 /buildghc/ghc/ && \ 31 | cd /buildghc/ghc && \ 32 | git submodule update --recursive --init && \ 33 | git apply /buildghc/ghc-patch/*.patch && \ 34 | ./boot && \ 35 | ./configure --disable-large-address-space --prefix=/sandbox/usr GHC="$GHC" ALEX=/buildghc/alex HAPPY=/buildghc/happy && \ 36 | export LANG=C.UTF-8 && \ 37 | ./hadrian/build -j16 install --docs=no-sphinx --prefix=/sandbox/usr && \ 38 | cd / && \ 39 | rm -r /buildghc/ghc && \ 40 | git clone https://github.com/haskell/cabal.git --branch cabal-install-v3.10.1.0 --depth 1 /buildghc/Cabal/ && \ 41 | "$CABAL" user-config init -f -a "symlink-bindir: /buildghc/" && \ 42 | cd /buildghc/Cabal && \ 43 | "$CABAL" install cabal-install -j16 -w "$GHC" && \ 44 | cd / && \ 45 | rm -r /buildghc/Cabal 46 | 47 | RUN CABAL_DIR=/buildghc/ PATH=/buildghc/:"$PATH" /buildghc/bin/cabal v1-install -j16 -w /sandbox/usr/bin/ghc --prefix=/sandbox/usr --haddock-all --disable-library-profiling --global \ 48 | adjunctions \ 49 | aeson \ 50 | attoparsec \ 51 | barbies \ 52 | bifunctors \ 53 | binary \ 54 | cereal \ 55 | conduit \ 56 | conduit-extra \ 57 | constraints \ 58 | criterion \ 59 | directory \ 60 | dlist \ 61 | either \ 62 | extra \ 63 | free \ 64 | generic-arbitrary \ 65 | generic-data \ 66 | generic-lens \ 67 | generic-monoid \ 68 | generics-sop \ 69 | hashable \ 70 | haskell-src-exts \ 71 | hspec \ 72 | kan-extensions \ 73 | lens \ 74 | lens-aeson \ 75 | lifted-async \ 76 | linear \ 77 | megaparsec \ 78 | memory \ 79 | microlens-th \ 80 | mmorph \ 81 | mono-traversable \ 82 | numbers \ 83 | optics \ 84 | parsec \ 85 | pretty-show \ 86 | pretty-simple \ 87 | primitive \ 88 | process \ 89 | profunctors \ 90 | QuickCheck \ 91 | random \ 92 | recursion-schemes \ 93 | reflection \ 94 | regex-applicative \ 95 | semialign \ 96 | semigroupoids \ 97 | singletons-base \ 98 | split \ 99 | stm \ 100 | strict \ 101 | syb \ 102 | tagged \ 103 | tasty \ 104 | th-abstraction \ 105 | these \ 106 | unliftio \ 107 | unordered-containers \ 108 | vector \ 109 | vector-algorithms \ 110 | vector-sized \ 111 | vinyl \ 112 | yaml 113 | 114 | RUN git clone https://github.com/mniip/discord-eval.git --depth 1 /discord-eval && \ 115 | cd /discord-eval && \ 116 | export CABAL_DIR=/buildghc/ && \ 117 | export CABAL="$(/ghcup whereis cabal 3.10.1.0)" && \ 118 | export GHC="$(/ghcup whereis ghc 9.2.8)" && \ 119 | "$CABAL" install -j16 -w "$GHC" --installdir=/usr/bin --install-method=copy && \ 120 | git clone https://github.com/mniip/sandbox.git --depth 1 /jail && \ 121 | cd /jail && \ 122 | make && \ 123 | touch /eval.log /input && \ 124 | chown nobody /eval.log /input /jail 125 | 126 | RUN apt-get purge -y \ 127 | autoconf \ 128 | debootstrap \ 129 | build-essential \ 130 | curl \ 131 | g++ \ 132 | gcc \ 133 | git \ 134 | libgmp-dev \ 135 | libncurses-dev \ 136 | python3 \ 137 | zlib1g-dev && \ 138 | apt-get autoremove -y && \ 139 | apt-get clean && \ 140 | rm -rf /var/lib/apt/lists/* && \ 141 | /ghcup nuke && \ 142 | cd / && \ 143 | rm -r /buildghc /discord-eval /ghcup 144 | 145 | COPY gcc /sandbox/usr/bin/gcc 146 | COPY runghci /sandbox/usr/lib/runghci 147 | COPY eval.yaml jail.conf / 148 | 149 | CMD su nobody -s /bin/sh -c 'LANG=C.UTF-8 exec /usr/bin/discord-eval' 150 | -------------------------------------------------------------------------------- /docker/buildghc/ghc-patch/0001-Wakeup.patch: -------------------------------------------------------------------------------- 1 | From 96ba92e8b69b1f18e2210f0a586d7e8edf8fbc0b Mon Sep 17 00:00:00 2001 2 | From: mniip 3 | Date: Sun, 18 Jun 2023 16:13:51 +0200 4 | Subject: [PATCH] Wakeup 5 | 6 | --- 7 | ghc/GHCi/UI.hs | 39 ++++++++++++++++++++---------------- 8 | libraries/ghci/GHCi/Run.hs | 4 +++- 9 | libraries/ghci/ghci.cabal.in | 3 +++ 10 | libraries/ghci/wakeup.c | 6 ++++++ 11 | 4 files changed, 34 insertions(+), 18 deletions(-) 12 | create mode 100644 libraries/ghci/wakeup.c 13 | 14 | diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs 15 | index 418502f306..c01c543d11 100644 16 | --- a/ghc/GHCi/UI.hs 17 | +++ b/ghc/GHCi/UI.hs 18 | @@ -35,6 +35,7 @@ import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' ) 19 | import GHCi.UI.Monad hiding ( args, runStmt ) 20 | import GHCi.UI.Tags 21 | import GHCi.UI.Info 22 | +import GHCi.Run ( primWakeup ) 23 | import GHC.Runtime.Debugger 24 | 25 | -- The GHC interface 26 | @@ -696,7 +697,7 @@ runGHCi paths maybe_exprs = do 27 | -- This would be a good place for runFileInputT. 28 | Right hdl -> 29 | do runInputTWithPrefs defaultPrefs defaultSettings $ 30 | - runCommands $ fileLoop hdl 31 | + runCommands (return ()) $ fileLoop hdl 32 | liftIO (hClose hdl `catchIO` \_ -> return ()) 33 | -- Don't print a message if this is really ghc -e (#11478). 34 | -- Also, let the user silence the message with -v0 35 | @@ -771,7 +772,7 @@ runGHCi paths maybe_exprs = do 36 | Nothing -> 37 | do 38 | -- enter the interactive loop 39 | - runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty 40 | + runGHCiInput $ runCommands (liftIO primWakeup) $ nextInputLine show_prompt is_tty 41 | Just exprs -> do 42 | -- just evaluate the expression we were given 43 | enqueueCommands exprs 44 | @@ -786,7 +787,7 @@ runGHCi paths maybe_exprs = do 45 | -- this used to be topHandlerFastExit, see #2228 46 | runInputTWithPrefs defaultPrefs defaultSettings $ do 47 | -- make `ghc -e` exit nonzero on failure, see #7962, #9916, #17560, #18441 48 | - _ <- runCommands' hdle 49 | + _ <- runCommands' (return ()) hdle 50 | (Just $ hdle (toException $ ExitFailure 1) >> return ()) 51 | (return Nothing) 52 | return () 53 | @@ -1065,14 +1066,15 @@ installInteractivePrint (Just ipFun) exprmode = do 54 | when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1)) 55 | 56 | -- | The main read-eval-print loop 57 | -runCommands :: InputT GHCi (Maybe String) -> InputT GHCi () 58 | -runCommands gCmd = runCommands' handler Nothing gCmd >> return () 59 | +runCommands :: InputT GHCi () -> InputT GHCi (Maybe String) -> InputT GHCi () 60 | +runCommands done gCmd = runCommands' done handler Nothing gCmd >> return () 61 | 62 | -runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler 63 | +runCommands' :: InputT GHCi () 64 | + -> (SomeException -> GHCi Bool) -- ^ Exception handler 65 | -> Maybe (GHCi ()) -- ^ Source error handler 66 | -> InputT GHCi (Maybe String) 67 | -> InputT GHCi () 68 | -runCommands' eh sourceErrorHandler gCmd = mask $ \unmask -> do 69 | +runCommands' done eh sourceErrorHandler gCmd = mask $ \unmask -> do 70 | b <- handle (\e -> case fromException e of 71 | Just UserInterrupt -> return $ Just False 72 | _ -> case fromException e of 73 | @@ -1081,12 +1083,12 @@ runCommands' eh sourceErrorHandler gCmd = mask $ \unmask -> do 74 | return Nothing 75 | _other -> 76 | liftIO (Exception.throwIO e)) 77 | - (unmask $ runOneCommand eh gCmd) 78 | + (unmask $ runOneCommand done eh gCmd) 79 | case b of 80 | Nothing -> return () 81 | Just success -> do 82 | unless success $ maybe (return ()) lift sourceErrorHandler 83 | - unmask $ runCommands' eh sourceErrorHandler gCmd 84 | + unmask $ runCommands' done eh sourceErrorHandler gCmd 85 | 86 | -- | Evaluate a single line of user input (either : or Haskell code). 87 | -- A result of Nothing means there was no more input to process. 88 | @@ -1094,20 +1096,23 @@ runCommands' eh sourceErrorHandler gCmd = mask $ \unmask -> do 89 | -- this is relevant only to ghc -e, which will exit with status 1 90 | -- if the command was unsuccessful. GHCi will continue in either case. 91 | -- TODO: replace Bool with CmdExecOutcome 92 | -runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String) 93 | +runOneCommand :: InputT GHCi () -> (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String) 94 | -> InputT GHCi (Maybe Bool) 95 | -runOneCommand eh gCmd = do 96 | +runOneCommand done eh gCmd = do 97 | -- run a previously queued command if there is one, otherwise get new 98 | -- input from user 99 | mb_cmd0 <- noSpace (lift queryQueue) 100 | mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0 101 | case mb_cmd1 of 102 | - Nothing -> return Nothing 103 | + Nothing -> return Nothing <* done 104 | Just c -> do 105 | st <- getGHCiState 106 | - ghciHandle (\e -> lift $ eh e >>= return . Just) $ 107 | + result <- ghciHandle (\e -> lift $ eh e >>= return . Just) $ 108 | handleSourceError printErrorAndFail $ 109 | cmd_wrapper st $ doCommand c 110 | + case result of 111 | + Nothing -> return result 112 | + _ -> done >> return result 113 | -- source error's are handled by runStmt 114 | -- is the handler necessary here? 115 | where 116 | @@ -1117,7 +1122,7 @@ runOneCommand eh gCmd = do 117 | 118 | noSpace q = q >>= maybe (return Nothing) 119 | (\c -> case removeSpaces c of 120 | - "" -> noSpace q 121 | + "" -> done >> noSpace q 122 | ":{" -> multiLineCmd q 123 | _ -> return (Just c) ) 124 | multiLineCmd q = do 125 | @@ -1135,7 +1140,7 @@ runOneCommand eh gCmd = do 126 | -- and since there is no (?) valid occurrence of \r (as 127 | -- opposed to its String representation, "\r") inside a 128 | -- ghci command, we replace any such with ' ' (argh:-( 129 | - collectCommand q c = q >>= 130 | + collectCommand q c = done >> q >>= 131 | maybe (liftIO (ioError collectError)) 132 | (\l->if removeSpaces l == ":}" 133 | then return (Just c) 134 | @@ -1166,7 +1171,7 @@ runOneCommand eh gCmd = do 135 | if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input 136 | then do 137 | fst_line_num <- line_number <$> getGHCiState 138 | - mb_stmt <- checkInputForLayout stmt gCmd 139 | + mb_stmt <- checkInputForLayout stmt (done >> gCmd) 140 | case mb_stmt of 141 | Nothing -> return CommandIncomplete 142 | Just ml_stmt -> do 143 | @@ -2518,7 +2523,7 @@ runScript filename = do 144 | new_st <- getGHCiState 145 | setGHCiState new_st{progname=prog,line_number=line} 146 | where scriptLoop script = do 147 | - res <- runOneCommand handler $ fileLoop script 148 | + res <- runOneCommand (return ()) handler $ fileLoop script 149 | case res of 150 | Nothing -> return () 151 | Just s -> if s 152 | diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs 153 | index 4ecb64620a..1ec87f0224 100644 154 | --- a/libraries/ghci/GHCi/Run.hs 155 | +++ b/libraries/ghci/GHCi/Run.hs 156 | @@ -9,7 +9,7 @@ 157 | -- compiler/GHC/Runtime/Interpreter.hs. 158 | -- 159 | module GHCi.Run 160 | - ( run, redirectInterrupts 161 | + ( run, redirectInterrupts, primWakeup 162 | ) where 163 | 164 | import Prelude -- See note [Why do we import Prelude here?] 165 | @@ -396,3 +396,5 @@ getIdValFromApStack apStack (I# stackDepth) = do 166 | case ok of 167 | 0# -> return Nothing -- AP_STACK not found 168 | _ -> return (Just (unsafeCoerce# result)) 169 | + 170 | +foreign import ccall unsafe "primWakeup" primWakeup :: IO () 171 | diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in 172 | index 78466a814a..cf11145e27 100644 173 | --- a/libraries/ghci/ghci.cabal.in 174 | +++ b/libraries/ghci/ghci.cabal.in 175 | @@ -58,6 +58,9 @@ library 176 | GHCi.StaticPtrTable 177 | GHCi.TH 178 | 179 | + c-sources: 180 | + wakeup.c 181 | + 182 | exposed-modules: 183 | GHCi.BreakArray 184 | GHCi.BinaryArray 185 | diff --git a/libraries/ghci/wakeup.c b/libraries/ghci/wakeup.c 186 | new file mode 100644 187 | index 0000000000..93b7ec4cd1 188 | --- /dev/null 189 | +++ b/libraries/ghci/wakeup.c 190 | @@ -0,0 +1,6 @@ 191 | +#include 192 | + 193 | +void primWakeup() 194 | +{ 195 | + asm volatile("syscall" :: "a"(0x77616b65) : "rcx", "r11"); 196 | +} 197 | -- 198 | 2.41.0 199 | 200 | -------------------------------------------------------------------------------- /docker/buildghc/ghc-patch/0002-Don-t-display-user-input-in-t-k.patch: -------------------------------------------------------------------------------- 1 | From c9e03662a9620df3eaaa5d29dbe61518d077a96d Mon Sep 17 00:00:00 2001 2 | From: mniip 3 | Date: Sun, 18 Jun 2023 16:05:57 +0200 4 | Subject: [PATCH] Don't display user input in :t/:k 5 | 6 | --- 7 | ghc/GHCi/UI.hs | 5 ++--- 8 | 1 file changed, 2 insertions(+), 3 deletions(-) 9 | 10 | diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs 11 | index 1f5f4c10ab..8c8ae8c40e 100644 12 | --- a/ghc/GHCi/UI.hs 13 | +++ b/ghc/GHCi/UI.hs 14 | @@ -2340,8 +2340,7 @@ typeOfExpr str = handleSourceError printErrAndMaybeExit $ 15 | where 16 | do_it mode expr_str 17 | = do { ty <- GHC.exprType mode expr_str 18 | - ; printForUser $ sep [ text expr_str 19 | - , nest 2 (dcolon <+> pprSigmaType ty)] } 20 | + ; printForUser $ pprSigmaType ty } 21 | 22 | ----------------------------------------------------------------------------- 23 | -- | @:type-at@ command 24 | @@ -2475,7 +2474,7 @@ showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc 25 | kindOfType :: GhciMonad m => Bool -> String -> m () 26 | kindOfType norm str = handleSourceError printErrAndMaybeExit $ do 27 | (ty, kind) <- GHC.typeKind norm str 28 | - printForUser $ vcat [ text str <+> dcolon <+> pprSigmaType kind 29 | + printForUser $ vcat [ pprSigmaType kind 30 | , ppWhen norm $ equals <+> pprSigmaType ty ] 31 | 32 | ----------------------------------------------------------------------------- 33 | -- 34 | 2.41.0 35 | 36 | -------------------------------------------------------------------------------- /docker/buildghc/ghc-patch/0003-Fix-disable-large-address-space.patch: -------------------------------------------------------------------------------- 1 | From a8f0435fc5516ad978064eeabcc24776b6b86351 Mon Sep 17 00:00:00 2001 2 | From: Cheng Shao 3 | Date: Sat, 13 May 2023 02:59:25 +0000 4 | Subject: [PATCH] rts: fix --disable-large-address-space 5 | 6 | This patch moves 7 | ACQUIRE_ALLOC_BLOCK_SPIN_LOCK/RELEASE_ALLOC_BLOCK_SPIN_LOCK from 8 | Storage.h to HeapAlloc.h. When --disable-large-address-space is passed 9 | to configure, the code in HeapAlloc.h makes use of these two macros. 10 | Fixes #23385. 11 | --- 12 | rts/sm/HeapAlloc.h | 8 ++++++++ 13 | rts/sm/Storage.h | 9 --------- 14 | 2 files changed, 8 insertions(+), 9 deletions(-) 15 | 16 | diff --git a/rts/sm/HeapAlloc.h b/rts/sm/HeapAlloc.h 17 | index b9f7c468be7..32210d12974 100644 18 | --- a/rts/sm/HeapAlloc.h 19 | +++ b/rts/sm/HeapAlloc.h 20 | @@ -10,6 +10,14 @@ 21 | 22 | #include "BeginPrivate.h" 23 | 24 | +#if defined(THREADED_RTS) 25 | +// needed for HEAP_ALLOCED below 26 | +extern SpinLock gc_alloc_block_sync; 27 | +#endif 28 | + 29 | +#define ACQUIRE_ALLOC_BLOCK_SPIN_LOCK() ACQUIRE_SPIN_LOCK(&gc_alloc_block_sync) 30 | +#define RELEASE_ALLOC_BLOCK_SPIN_LOCK() RELEASE_SPIN_LOCK(&gc_alloc_block_sync) 31 | + 32 | /* ----------------------------------------------------------------------------- 33 | The HEAP_ALLOCED() test. 34 | 35 | diff --git a/rts/sm/Storage.h b/rts/sm/Storage.h 36 | index c6046de2c0b..9c86abfc2bf 100644 37 | --- a/rts/sm/Storage.h 38 | +++ b/rts/sm/Storage.h 39 | @@ -43,15 +43,6 @@ extern Mutex sm_mutex; 40 | #define ASSERT_SM_LOCK() 41 | #endif 42 | 43 | -#if defined(THREADED_RTS) 44 | -// needed for HEAP_ALLOCED below 45 | -extern SpinLock gc_alloc_block_sync; 46 | -#endif 47 | - 48 | -#define ACQUIRE_ALLOC_BLOCK_SPIN_LOCK() ACQUIRE_SPIN_LOCK(&gc_alloc_block_sync) 49 | -#define RELEASE_ALLOC_BLOCK_SPIN_LOCK() RELEASE_SPIN_LOCK(&gc_alloc_block_sync) 50 | - 51 | - 52 | /* ----------------------------------------------------------------------------- 53 | The write barrier for MVARs and TVARs 54 | -------------------------------------------------------------------------- */ 55 | -- 56 | GitLab 57 | 58 | -------------------------------------------------------------------------------- /docker/eval.yaml: -------------------------------------------------------------------------------- 1 | logFile: /dev/null 2 | token: AAAAAAAAAAAAAAAAAAAAAAAA.AAAAAA.AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 3 | testGuilds: ["535174642017632276"] 4 | isTest: true 5 | forgetAfterSeconds: 600 6 | blockCountLimit: 10 7 | msgSizeLimit: 2000 8 | pastebinSizeLimit: 131068 9 | reactWait: 10 | name: "\u231B" 11 | reactCancel: 12 | name: "\u274C" 13 | emptyOutput: "\u2705" 14 | interpreters: 15 | ghci: 16 | tag: LiveState 17 | runCommand: 18 | - /jail/sandbox 19 | - /jail.conf 20 | - Dghci 21 | resetCommand: 22 | - /jail/sandbox 23 | - /jail.conf 24 | - kill 25 | - Dghci 26 | defaultInline: 27 | interpreter: ghci 28 | stripControl: true 29 | defaultCodeBlock: 30 | interpreter: ghci 31 | prefix: ":{\n" 32 | suffix: "\n:}\n" 33 | codeBlockLanguages: 34 | hs: 35 | interpreter: ghci 36 | prefix: ":{\n" 37 | suffix: "\n:}\n" 38 | haskell: 39 | interpreter: ghci 40 | prefix: ":{\n" 41 | suffix: "\n:}\n" 42 | -------------------------------------------------------------------------------- /docker/gcc: -------------------------------------------------------------------------------- 1 | #!/sandbox/bin/bash 2 | while [[ $# -gt 1 ]] 3 | do 4 | opt="$1" 5 | if [ "$opt" == "--print-file-name" ] 6 | then 7 | shift 8 | file="$1" 9 | case "$file" in 10 | "libc.so") echo "/sandbox/usr/lib/x86_64-linux-gnu/libc.so.6" ;; 11 | "libm.so") echo "/sandbox/usr/lib/x86_64-linux-gnu/libm.so.6" ;; 12 | "libgmp.so") echo "/sandbox/lib/x86_64-linux-gnu/libgmp.so.10" ;; 13 | "librt.so") echo "/sandbox/lib/x86_64-linux-gnu/librt.so.1" ;; 14 | "libutil.so") echo "/sandbox/lib/x86_64-linux-gnu/libutil.so.1" ;; 15 | "libdl.so") echo "/sandbox/lib/x86_64-linux-gnu/libdl.so.2" ;; 16 | "libpthread.so") echo "/sandbox/lib/x86_64-linux-gnu/libpthread.so.0" ;; 17 | *) echo "$file" 18 | esac 19 | fi 20 | shift 21 | done 22 | -------------------------------------------------------------------------------- /docker/jail.conf: -------------------------------------------------------------------------------- 1 | clearenv 2 | setenv PATH /sandbox/usr/bin/ 3 | setenv SHELL /sandbox/bin/sh 4 | setenv HOME /sandbox/tmp 5 | 6 | chdir /sandbox/tmp/ 7 | closefds 8 | 9 | see /sandbox/ 10 | see /dev/null 11 | see /dev/zero 12 | see /proc/self 13 | see /bin/dash 14 | write /sandbox/tmp/ 15 | 16 | rlimit CORE 0 17 | rlimit NOFILE 32 18 | rlimit AS 1073741824 19 | maxthreads 16 20 | timelimit 5 21 | 22 | sockdir /jail/ 23 | 24 | ident Dghci 25 | program /sandbox/usr/lib/runghci/runghci 26 | arg ghci 27 | 28 | rlimit AS 1073741824 29 | 30 | setenv LD_LIBRARY_PATH /sandbox/lib/x86_64-linux-gnu/:/sandbox/usr/lib/ghc-9.6.2/lib/x86_64-linux-ghc-9.6.2/ 31 | 32 | wakeup 33 | end 34 | -------------------------------------------------------------------------------- /docker/runghci/init: -------------------------------------------------------------------------------- 1 | :set -Wno-deprecated-flags -XGHC2021 -XAllowAmbiguousTypes -XApplicativeDo -XArrows -XBlockArguments -XDatatypeContexts -XDefaultSignatures -XDeriveAnyClass -XDerivingVia -XDuplicateRecordFields -XFunctionalDependencies -XGADTs -XImplicitParams -XImpredicativeTypes -XIncoherentInstances -XLambdaCase -XLexicalNegation -XLiberalTypeSynonyms -XLinearTypes -XMagicHash -XMonadComprehensions -XMultiWayIf -XNegativeLiterals -XNoImplicitPrelude -XNondecreasingIndentation -XNPlusKPatterns -XNumDecimals -XOverloadedLabels -XOverloadedRecordDot -XOverloadedStrings -XPackageImports -XParallelListComp -XPartialTypeSignatures -XPatternSynonyms -XQualifiedDo -XQuantifiedConstraints -XQuasiQuotes -XRecordWildCards -XRecursiveDo -XRoleAnnotations -XTemplateHaskell -XTransformListComp -XTypeData -XTypeFamilyDependencies -XUnboxedSums -XUnboxedTuples -XUndecidableInstances -XUndecidableSuperClasses -XUnicodeSyntax -XUnliftedDatatypes -XUnliftedFFITypes -XUnliftedNewtypes -XViewPatterns 2 | 3 | :module Conduit Control.Applicative Control.Applicative.Backwards Control.Comonad Control.Comonad.Hoist.Class Control.Comonad.Density Control.Concurrent.STM Control.Concurrent.STM.TSem Control.DeepSeq Control.Exception.Lens Control.Lens.Extras Control.Lens.Internal.Bazaar Control.Lens.Profunctor Control.Lens.Unsound Control.Monad Control.Monad.Accum Control.Monad.Catch Control.Monad.Catch.Pure Control.Monad.Co Control.Monad.Cont Control.Monad.Error.Class Control.Monad.Except Control.Monad.Fix Control.Monad.Free Control.Monad.Identity Control.Monad.IO.Class Control.Monad.Reader Control.Monad.RWS Control.Monad.Select Control.Monad.ST Control.Monad.State Control.Monad.Writer Control.Monad.Zip Criterion Data.Aeson.Lens Data.Align Data.Array.Byte Data.Biapplicative Data.Bifoldable Data.Bifoldable1 Data.Bifunctor Data.Bifunctor.Biap Data.Bifunctor.Biff Data.Bifunctor.Clown Data.Bifunctor.Fix Data.Bifunctor.Flip Data.Bifunctor.Functor Data.Bifunctor.Join Data.Bifunctor.Joker Data.Bifunctor.Product Data.Bifunctor.Sum Data.Bifunctor.Tannen Data.Bifunctor.TH Data.Bifunctor.Wrapped Data.Bitraversable Data.Bits Data.Bool Data.Char Data.Coerce Data.Complex Data.Conduit.Combinators.Stream Data.Constraint.Deferrable Data.Constraint.Forall Data.Constraint.Lifting Data.Constraint.Symbol Data.Constraint.Unsafe Data.Containers.ListUtils Data.Crosswalk Data.Dynamic Data.Either Data.Fixed Data.Function Data.Functor Data.Functor.Classes Data.Functor.Compose Data.Functor.Composition Data.Functor.Constant Data.Functor.Contravariant Data.Functor.Coyoneda Data.Functor.Identity Data.Functor.Kan.Lan Data.Functor.Kan.Ran Data.Functor.Reverse Data.Functor.These Data.Functor.Yoneda Data.Graph Data.Hashable Data.Hashable.Generic Data.Hashable.Lifted Data.Int Data.IORef Data.Ix Data.Kind Data.List.Split Data.Maybe Data.MonoTraversable Data.Number.BigFloat Data.Number.CReal Data.Number.Dif Data.Number.Interval Data.Number.Symbolic Data.Ord Data.Profunctor.Adjunction Data.Profunctor.Cayley Data.Profunctor.Choice Data.Profunctor.Closed Data.Profunctor.Composition Data.Profunctor.Mapping Data.Profunctor.Monad Data.Profunctor.Sieve Data.Profunctor.Strong Data.Profunctor.Unsafe Data.Proxy Data.Ratio Data.Semialign Data.Semialign.Indexed Data.Semigroup.Bifoldable Data.Semigroup.Bitraversable Data.Semigroup.Foldable Data.Semigroup.Traversable Data.STRef Data.String Data.Tagged Data.These Data.These.Combinators Data.Time Data.Time.Calendar.Easter Data.Time.Calendar.Julian Data.Time.Calendar.Month Data.Time.Calendar.MonthDay Data.Time.Calendar.OrdinalDate Data.Time.Calendar.Quarter Data.Time.Calendar.WeekDate Data.Time.Clock.POSIX Data.Time.Clock.System Data.Time.Clock.TAI Data.Time.Format.ISO8601 Data.Traversable Data.Traversable.Instances Data.Tree Data.Tuple Data.Type.Bool Data.Type.Equality Data.Type.Ord Data.Unique Data.Version Data.Void Data.Word Data.Zip Debug.Trace Foreign.C Foreign.C.ConstPtr Foreign.Marshal.Unsafe GHC.OverloadedLabels GHC.Pack GHC.Read GHC.Records GHC.Stack GHC.Stats GHC.TypeError GHC.TypeNats GHC.Types GHC.Unicode GHC.Weak Language.Haskell.TH.Quote Numeric Numeric.Natural System.Console.GetOpt System.CPUTime System.Directory System.Environment System.Exit System.FilePath System.Info System.IO System.IO.Unsafe System.Mem System.Mem.StableName System.Mem.Weak System.Posix.Internals System.Posix.Types Test.Tasty Text.Printf Text.Show Text.Show.Functions Type.Reflection Type.Reflection.Unsafe Unsafe.Coerce 4 | 5 | import "base" Prelude hiding (repeat, unzip, zip, zipWith) 6 | import "base" Control.Arrow hiding (first, second) 7 | import "base" Control.Arrow qualified as A 8 | import "base" Control.Category hiding (id, (.)) 9 | import "base" Control.Category qualified as C 10 | import "base" Control.Concurrent hiding (yield) 11 | import "base" Control.Exception.Base hiding (bracket, bracket_, bracketOnError, catch, catchJust, finally, handle, handleJust, mask, mask_, onException, try, tryJust, TypeError, uninterruptibleMask, uninterruptibleMask_) 12 | import "base" Control.Exception hiding (bracket, bracket_, bracketOnError, catch, catches, catchJust, finally, handle, handleJust, Handler, mask, mask_, onException, try, tryJust, TypeError, uninterruptibleMask, uninterruptibleMask_) 13 | import "base" Data.Foldable1 hiding (foldl1, foldr1, head, last, maximum, maximumBy, minimum, minimumBy) 14 | import "base" Data.Foldable hiding (toList) 15 | import "base" Data.Foldable qualified as F 16 | import "base" Data.List hiding (foldl1', repeat, uncons, unzip, zip, zipWith) 17 | import "base" Data.Type.Coercion hiding (sym, trans) 18 | import "base" Foreign hiding (void) 19 | import "base" GHC.Exts hiding (traceEvent) 20 | import "base" GHC.Generics hiding (from, moduleName, to) 21 | import "base" GHC.IO hiding (bracket, catch, finally, liftIO, mask, mask_, onException, uninterruptibleMask, uninterruptibleMask_) 22 | import "base" GHC.OldList qualified as L 23 | import "base" System.IO.Error hiding (catchIOError) 24 | import "base" System.Timeout hiding (Timeout) 25 | import "aeson" Data.Aeson (FromJSON, ToJSON, Value) 26 | import "array" Data.Array.Unboxed (Array, UArray) 27 | import "array" Data.Array.IArray qualified as A 28 | import "array" Data.Array.MArray qualified as A 29 | import "bytestring" Data.ByteString (ByteString, StrictByteString) 30 | import "bytestring" Data.ByteString qualified as BS 31 | import "bytestring" Data.ByteString.Char8 qualified as BSC 32 | import "bytestring" Data.ByteString.Lazy (LazyByteString) 33 | import "bytestring" Data.ByteString.Lazy qualified as BSL 34 | import "bytestring" Data.ByteString.Lazy.Char8 qualified as BSLC 35 | import "bytestring" Data.ByteString.Short (ShortByteString) 36 | import "bytestring" Data.ByteString.Short qualified as BSS 37 | import "constraints" Data.Constraint hiding (trans, withDict, (***), (&&&), (\\)) 38 | import "containers" Data.IntMap (IntMap) 39 | import "containers" Data.IntMap qualified as IM 40 | import "containers" Data.IntSet (IntSet) 41 | import "containers" Data.IntSet qualified as IS 42 | import "containers" Data.Map (Map) 43 | import "containers" Data.Map qualified as M 44 | import "containers" Data.Sequence (Seq) 45 | import "containers" Data.Sequence qualified as Seq 46 | import "containers" Data.Set (Set) 47 | import "containers" Data.Set qualified as S 48 | import "free" Control.Comonad.Cofree hiding (unfold, unfoldM) 49 | import "kan-extensions" Control.Monad.Codensity hiding (shift) 50 | import "lens" Control.Lens hiding (from, index, lazy, levels, para, Strict, (:<), (<.>)) 51 | import "process" System.Process hiding (env) 52 | import "profunctors" Data.Profunctor hiding (WrappedArrow(..), (:->)) 53 | import "QuickCheck" Test.QuickCheck hiding (choose, elements, Fixed, Fun, label, (.&.)) 54 | import "random" System.Random hiding (split) 55 | import "recursion-schemes" Data.Functor.Base hiding (head, tail) 56 | import "recursion-schemes" Data.Functor.Foldable hiding (fold, unfold) 57 | import "reflection" Data.Reflection hiding (D) 58 | import "template-haskell" Language.Haskell.TH hiding (DecidedStrictness(..), Fixity, interruptible, reify, sourceLazy, SourceStrictness(..), SourceUnpackedness(..), Type) 59 | import "template-haskell" Language.Haskell.TH.Syntax hiding (DecidedStrictness(..), Fixity, Infix, Lift, lift, Module, reify, SourceStrictness(..), SourceUnpackedness(..), Type) 60 | import "text" Data.Text (Text) 61 | import "text" Data.Text qualified as T 62 | import "text" Data.Text.Encoding qualified as T 63 | import "text" Data.Text.Encoding.Error qualified as T 64 | import "text" Data.Text.IO qualified as T 65 | import "text" Data.Text.Lazy qualified as TL 66 | import "text" Data.Text.Lazy.Encoding qualified as TL 67 | import "text" Data.Text.Lazy.IO qualified as TL 68 | import "transformers" Control.Applicative.Lift hiding (Pure) 69 | import "unordered-containers" Data.HashMap.Lazy (HashMap) 70 | import "unordered-containers" Data.HashMap.Lazy qualified as HM 71 | import "unordered-containers" Data.HashSet (HashSet) 72 | import "unordered-containers" Data.HashSet qualified as HS 73 | import "vector" Data.Vector (Vector) 74 | import "vector" Data.Vector qualified as V 75 | import "vector" Data.Vector.Mutable (MVector) 76 | import "vector" Data.Vector.Mutable qualified as MV 77 | 78 | hSetEncoding stdin utf8 >> hSetEncoding stdout utf8 >> hSetEncoding stderr utf8 79 | pPrint = Text.Pretty.Simple.pPrintOpt Text.Pretty.Simple.NoCheckColorTty Text.Pretty.Simple.defaultOutputOptionsNoColor { Text.Pretty.Simple.outputOptionsCompact = True } 80 | 81 | :set prompt "" 82 | :set -dppr-cols10000 -interactive-print pPrint -v1 83 | -------------------------------------------------------------------------------- /docker/runghci/runghci: -------------------------------------------------------------------------------- 1 | #!/sandbox/bin/sh 2 | if [ ! -e /sandbox/tmp/ghci ]; then 3 | mkdir /sandbox/tmp/ghci 4 | fi 5 | exec /sandbox/usr/bin/ghc -dynload deploy --interactive -v0 -ghci-script /sandbox/usr/lib/runghci/init -tmpdir /sandbox/tmp/ghci/ -odir /sandbox/tmp/ghci/ -hidir /sandbox/tmp/ghci/ -ignore-dot-ghci +RTS -M200M -V0 -C0 -K100M 6 | --------------------------------------------------------------------------------