Paste

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