diff options
Diffstat (limited to 'src/Ghci.hs')
-rw-r--r-- | src/Ghci.hs | 45 |
1 files changed, 32 insertions, 13 deletions
diff --git a/src/Ghci.hs b/src/Ghci.hs index 97943db..953bf72 100644 --- a/src/Ghci.hs +++ b/src/Ghci.hs @@ -8,6 +8,9 @@ module Ghci ( runStmt, runStmtClever, terminateGhci, + ParseSettings(..), + parseSettingsReply, + parseSettingsPaste, ) where import Control.Exception (catch, SomeException) @@ -46,6 +49,18 @@ data Ghci = Ghci , ghciStdout :: Handle } +data ParseSettings = ParseSettings + { psMaxOutputLen :: Int -- ^ How much date to return, at most (will add '...') + , psJoinLines :: Bool -- ^ Whether to join lines with ';' + } + deriving (Show) + +parseSettingsReply :: ParseSettings +parseSettingsReply = ParseSettings 200 True + +parseSettingsPaste :: ParseSettings +parseSettingsPaste = ParseSettings 50000 False + data Result a = Error String | Ignored | Return a deriving (Show) @@ -65,8 +80,8 @@ makeGhci = do , ghciStdin = stdinH , ghciStdout = pipeOut } -runStmtClever :: Ghci -> String -> IO (Ghci, Result String) -runStmtClever ghci line = +runStmtClever :: Ghci -> ParseSettings -> String -> IO (Ghci, Result String) +runStmtClever ghci pset line = case dropWhile isSpace line of ':' : line1 -> case words (map toLower (dropWhile isSpace line1)) of ('!':_) : _ -> return (ghci, Ignored) @@ -80,14 +95,14 @@ runStmtClever ghci line = hFlush stdout ghci' <- makeGhci return (ghci', Return "") - _ -> runStmt ghci line - _ -> runStmt ghci line + _ -> runStmt ghci pset line + _ -> runStmt ghci pset line where startsWith :: String -> String -> Bool long `startsWith` short = take (length short) long == short -runStmt :: Ghci -> String -> IO (Ghci, Result String) -runStmt ghci line = timeouting 2_000_000 (restarting (\g -> runStmt' g line)) ghci +runStmt :: Ghci -> ParseSettings -> String -> IO (Ghci, Result String) +runStmt ghci pset line = timeouting 2_000_000 (restarting (\g -> runStmt' g pset line)) ghci timeouting :: Int -> (Ghci -> IO (Ghci, Result a)) -> Ghci -> IO (Ghci, Result a) timeouting microseconds f ghci = @@ -138,24 +153,28 @@ restarting f ghci = do terminateGhci :: Ghci -> IO () terminateGhci ghci = terminateProcess (ghciProc ghci) -runStmt' :: Ghci -> String -> IO String -runStmt' ghci stmt = do +runStmt' :: Ghci -> ParseSettings -> String -> IO String +runStmt' ghci pset stmt = do tag <- updatePrompt ghci ghciPutStrLn (ghciStdin ghci) stmt hFlush (ghciStdin ghci) - (output, reason) <- hGetUntilUTF8 (ghciStdout ghci) (Just 8192) tag + let readmax = psMaxOutputLen pset + 200 + (output, reason) <- hGetUntilUTF8 (ghciStdout ghci) (Just readmax) tag case reason of ReachedMaxLen -> do terminateGhci ghci -- because we lost the new prompt - return (formatOutput output) -- don't need to strip tag because 200 << 8192 + return (formatOutput output) -- don't need to strip tag because we read more than the max output len ReachedTag -> return (formatOutput $ take (length output - length tag) output) ReachedEOF -> do terminateGhci ghci return (formatOutput output) where - formatOutput (replaceNewlines . dropBothSlow isSpace -> output) - | length output > 200 = take 197 output ++ "..." - | otherwise = output + formatOutput output = + let output' | psJoinLines pset = replaceNewlines (dropBothSlow isSpace output) + | otherwise = output + in if length output' > psMaxOutputLen pset + then take (psMaxOutputLen pset - 3) output' ++ "..." + else output' dropBothSlow f = reverse . dropWhile f . reverse . dropWhile f replaceNewlines = concatMap (\case '\n' -> " ; " ; c -> [c]) |