Initial

1 files changed, 172 insertions, 0 deletions

diff --git a/src/Ghci.hs b/src/Ghci.hs
new file mode 100644
index 0000000..fbbaa65
--- /dev/null
+++ b/src/Ghci.hs
@@ -0,0 +1,172 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ViewPatterns #-}
+module Ghci (
+  Ghci,
+  Result(..),
+  makeGhci,
+  runStmt,
+  runStmtClever,
+  terminateGhci,
+) where
+
+import Control.Exception (catch, SomeException)
+import Control.Monad (replicateM, when)
+import Data.Bifunctor (first)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as BSB
+import qualified Data.ByteString.Lazy as Lazy
+import qualified Data.ByteString.UTF8 as UTF8
+import qualified Data.ByteString.Lazy.UTF8 as LUTF8
+import Data.ByteString.Short (ShortByteString)
+import qualified Data.ByteString.Short as BSS
+import Data.Char (isSpace, toLower)
+import Data.List (nub)
+import Foreign
+import System.IO
+import System.Process
+import System.Random hiding (next)
+
+import ExitEarly
+
+
+data Ghci = Ghci
+  { ghciProc :: ProcessHandle
+  , ghciStdin :: Handle
+  , ghciStdout :: Handle
+  }
+
+data Result a = Error String | Ignored | Return a
+  deriving (Show)
+
+makeGhci :: IO Ghci
+makeGhci = do
+  (pipeOut, pipeIn) <- createPipe
+  (Just stdinH, _, _, proch) <- createProcess
+    (proc "./start.sh" [])
+      { cwd = Just "bwrap-files"
+      , std_in = CreatePipe
+      , std_out = UseHandle pipeIn
+      , std_err = UseHandle pipeIn }
+  return Ghci { ghciProc = proch
+              , ghciStdin = stdinH
+              , ghciStdout = pipeOut }
+
+runStmtClever :: Ghci -> String -> IO (Ghci, Result String)
+runStmtClever ghci line =
+  case dropWhile isSpace line of
+    ':' : line1 -> case words (map toLower (dropWhile isSpace line1)) of
+      ('!':_) : _ -> return (ghci, Ignored)
+      cmd : "prompt" : _
+        | "set" `startsWith` cmd -> return (ghci, Ignored)
+      cmd : _
+        | "def" `startsWith` cmd -> return (ghci, Ignored)
+        | "quit" `startsWith` cmd -> do
+            terminateGhci ghci
+            ghci' <- makeGhci
+            return (ghci', Return "")
+      _ -> runStmt ghci line
+    _ -> runStmt ghci line
+  where
+    startsWith :: String -> String -> Bool
+    long `startsWith` short = take (length short) long == short
+
+runStmt :: Ghci -> String -> IO (Ghci, Result String)
+runStmt ghci line = restarting 1 (\g -> runStmt' g line) ghci
+
+restarting :: Int -> (Ghci -> IO a) -> Ghci -> IO (Ghci, Result a)
+restarting numExcRestarts f ghci = do
+  closed <- hIsClosed (ghciStdin ghci)
+  ghci' <- if closed
+             then do
+               terminateGhci ghci
+               makeGhci
+             else return ghci
+  (f ghci' >>= \x -> return (ghci', Return x))
+    `catch` (\e -> do let _ = e :: SomeException
+                      terminateGhci ghci'
+                      ghci'' <- makeGhci
+                      if numExcRestarts >= 1
+                        then restarting (numExcRestarts - 1) f ghci''
+                        else return (ghci'', Error "Oops, something went wrong"))
+
+terminateGhci :: Ghci -> IO ()
+terminateGhci ghci = terminateProcess (ghciProc ghci)
+
+runStmt' :: Ghci -> String -> IO String
+runStmt' ghci stmt = do
+  tag <- updatePrompt ghci
+  hPutStrLn (ghciStdin ghci) stmt
+  hFlush (ghciStdin ghci)
+  (output, reason) <- hGetUntilUTF8 (ghciStdout ghci) (Just 8192) 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
+    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
+    dropBothSlow f = reverse . dropWhile f . reverse . dropWhile f
+    replaceNewlines = map (\case '\n' -> ' ' ; c -> c)
+
+-- | Returns new prompt tag
+updatePrompt :: Ghci -> IO String
+updatePrompt ghci = do
+  tag <- genTag
+  -- putStrLn ("chose prompt: " ++ tag)
+  hPutStrLn (ghciStdin ghci) (":set prompt " ++ tag)
+  hFlush (ghciStdin ghci)
+  -- putStrLn ("set prompt " ++ tag)
+  _ <- hGetUntilUTF8 (ghciStdout ghci) (Just 8192) tag
+  return tag
+
+genTag :: IO String
+genTag = replicateM 20 (getStdRandom (uniformR ('a', 'z')))
+
+data CutoffReason = ReachedMaxLen | ReachedTag | ReachedEOF
+  deriving (Show)
+
+hGetUntilUTF8 :: Handle -> Maybe Int -> String -> IO (String, CutoffReason)
+hGetUntilUTF8 h mmax tag =
+  first LUTF8.toString <$> hGetUntil h mmax (BSS.toShort (UTF8.fromString tag))
+
+hGetUntil :: Handle -> Maybe Int -> ShortByteString -> IO (Lazy.ByteString, CutoffReason)
+hGetUntil h mmax tag = do
+  let size = 1024
+      exceedsMax yet = case mmax of Just m -> yet >= m
+                                    Nothing -> True
+  -- putStrLn ("tag = " ++ show tag)
+  allocaBytes size $ \ptr -> do
+    let loop yet havePrefixes builder = do
+          when (exceedsMax yet) $ exitEarly (BSB.toLazyByteString builder, ReachedMaxLen)
+
+          nread <- lift $ hGetBufSome h ptr size
+          when (nread <= 0) $ exitEarly (BSB.toLazyByteString builder, ReachedEOF)
+
+          bs <- lift $ BS.packCStringLen (ptr, nread)
+          -- lift $ putStrLn ("Read: " ++ show bs)
+          when (or [BSS.toShort (BS.takeEnd suflen bs) == BSS.takeEnd suflen tag
+                   | n <- 0 : havePrefixes
+                   , let suflen = BSS.length tag - n]) $ do
+            -- lift $ putStrLn "yay determined end"
+            exitEarly (BSB.toLazyByteString (builder <> BSB.byteString bs)
+                      ,ReachedTag)
+
+          let nextPrefixes =
+                nub $
+                  [plen + BS.length bs  -- continuations of partial matches
+                  | plen <- havePrefixes
+                  , BS.length bs < BSS.length tag - plen
+                  , BSS.toShort bs == BSS.take (BS.length bs) (BSS.drop plen tag)]
+                  ++
+                  [n  -- new matches
+                  | n <- [1 .. min (BS.length bs) (BSS.length tag)]
+                  , BSS.toShort (BS.takeEnd n bs) == BSS.take n tag]
+          -- lift $ putStrLn ("nextPrefixes = " ++ show nextPrefixes)
+          loop (yet + nread) nextPrefixes (builder <> BSB.byteString bs)
+    result <- execExitEarlyT (loop 0 [] mempty)
+    return $! result