Skip to content
Browse files

overhaul input/output

  • Loading branch information...
1 parent 53b16d9 commit b690371077e7f6dec3acb57cebd9cc39f7aba39a @mikeplus64 committed Jan 31, 2013
Showing with 90 additions and 86 deletions.
  1. +90 −86 src/Language/Haskell/Repl.hs
View
176 src/Language/Haskell/Repl.hs
@@ -7,125 +7,125 @@ import Control.Monad
import Control.Arrow
import Data.Dynamic
import GHC
-import GHC.Paths (libdir)
+import GHC.Paths
import DynFlags
import GhcMonad
-import Outputable (showSDocForUser, ppr, neverQualify, Outputable)
+import Outputable
import Data.IORef
import Data.Maybe
-import Data.Foldable (for_)
data Input
- = Type { input :: String }
- | Kind { input :: String }
- | Info { input :: String }
- | Decl { input :: String }
- | Bind { input :: String }
- | Expr { input :: String }
- | Undefine { input :: String }
+ = Type String
+ | Kind String
+ | Info String
+ | Decl String
+ | Bind String
+ | Expr String
+ | Undefine String
| Clear
deriving Show
+data ReplOutput
+ = ReplError String
+ | GhcError String
+ | Output [String]
+ deriving Show
+
data Output
- = ReplError { failure :: String }
- | GhcError { failure :: String }
- | Output { output :: [String] }
+ = OK [String]
+ | Errors [String]
+ | Partial [String]
+ | Timeout
deriving Show
data Repl = Repl
{ inputChan :: Chan Input
- , outputChan :: Chan Output
+ , outputChan :: Chan ReplOutput
, interpreter :: ThreadId
- , patienceForResult :: Maybe Double
- , patienceForErrors :: Maybe Int
- , lineLength :: Maybe Int
+ , patienceForResult :: Double
+ , lineLength :: Int
}
-{-
-enter :: Repl
- -> Input
- -> IO ()
-enter r x = writeChan (input r) x
+(!?) :: [a] -> Int -> Maybe a
+ys !? i
+ | i >= 0 = go 0 ys
+ | otherwise = Nothing
+ where
+ go _ [] = Nothing
+ go j (x:xs)
+ | j == i = Just x
+ | otherwise = go (j+1) xs
+
+input :: Repl -> Input -> IO ()
+input = writeChan . inputChan
-- | Naiively get the next set of results. This /does not/ take into account
-- 'patienceForResults', 'patienceForErrors', or 'lineLength'.
-results :: Repl -> IO [String]
-results = readChan . output
+output :: Repl -> IO ReplOutput
+output = readChan . outputChan
-- | Enter commands and an expression to a 'Repl', and immediately consume results.
-- However, truncate input to the given length, and stop the computation after the
-- given amount of time in seconds.
prompt
:: Repl
-> Input
- -> IO [String]
-prompt r xs x = do
- let trimLine = case lineLength r of
- Just l -> take l
- _ -> id
- enter r xs x
- lazyResults <- results r
- final <- newEmptyMVar
- timeout <- forkIO (patienceForResult r `for_` \ p -> do
- threadDelay (floor (p*1000000))
- putMVar final ["Thread timed out."])
- attempt <- forkIO $ case patienceForErrors r of
- Just p -> do
- (tr,ir) <- progress lazyResults
- threadDelay p
- killThread tr
- prog <- readIORef ir
- let hs = map trimLine (take prog lazyResults)
- ends hs `seq` putMVar final hs
-
- _ -> putMVar final (map trimLine lazyResults)
-
- fin <- takeMVar final
- killThread timeout
- killThread attempt
- return fin
-
-promptWith
- :: Repl
- -> (String -> IO a)
- -> [String]
- -> String
- -> IO ()
-promptWith r f xs x = prompt r xs x >>= mapM_ f
--}
+ -> IO Output
+prompt repl x = do
+ input repl x
+ results <- output repl
+ threads <- newIORef []
+
+ let fork f = forkIO f >>= \t -> modifyIORef threads (t:)
+ prog ys = do
+ acc <- newIORef 0
+ fork $ forM_ ys $ \_ -> modifyIORef acc (\i -> if i > lineLength repl then i else i+1)
+ return acc
+
+ unlessError results $ \ res -> do
+ final <- newEmptyMVar
+ outputs <- newIORef []
+
+ -- Time out
+ fork $ do
+ threadDelay (floor (patienceForResult repl*1000000))
+ u <- readIORef outputs
+ case res !? length u of
+ Nothing -> putMVar final (if null u then Timeout else Partial u)
+ Just h -> do
+ p <- prog h
+ i <- readIORef p
+ putMVar final (Partial (u ++ [take i h]))
+
+ -- Return everything
+ fork $ do
+ let r = map trim res
+ forM_ r $ \l -> ends l `seq` modifyIORef outputs (++ [l])
+ putMVar final (OK r)
+
+ fin <- takeMVar final
+ mapM_ killThread =<< readIORef threads
+ return fin
+ where
+ trim = take (lineLength repl)
+
+ unlessError (ReplError s) _ = return . Errors . map trim . lines $ s
+ unlessError (GhcError s) _ = return . Errors . map trim . lines $ s
+ unlessError (Output s) f = f s
-- | See if a lazy list has ended.
ends :: [a] -> Bool
ends [] = True
ends (_:xs) = ends xs
--- | See 'how far' a lazy list has evaluated.
-progress :: [a] -> IO (ThreadId, IORef Int)
-progress [] = (,) <$> forkIO (return ()) <*> newIORef 0
-progress xs = do
- r <- newIORef 0
- let go [] = return ()
- go (_:ys) = modifyIORef r (+1) >> go ys
- t <- forkIO (go xs)
- return (t, r)
-
stopRepl :: Repl -> IO ()
stopRepl = killThread . interpreter
newRepl :: IO Repl
newRepl = do
inp <- newChan
out <- newChan
- repl' defaultImports defaultExtensions inp out defaultWait defaultErrorWait defaultLineLength
-
-defaultWait :: Maybe Double
-defaultWait = Just 5
-
-defaultErrorWait :: Maybe Int
-defaultErrorWait = Just 3000
-
-defaultLineLength :: Maybe Int
-defaultLineLength = Just 512
+ repl' defaultImports defaultExtensions inp out Nothing Nothing
defaultImports :: [String]
defaultImports
@@ -149,7 +149,6 @@ defaultImports
,"import Control.Monad.Fix"
,"import Control.Applicative"
,"import Control.Lens"
- ,"import Data.Monoid"
,"import Data.Functor"
,"import Data.Typeable"]
@@ -172,7 +171,13 @@ defaultExtensions
,Opt_FunctionalDependencies
,Opt_GADTs]
-prompt_ :: Repl -> Input -> IO Output
+defaultLineLength :: Int
+defaultLineLength = 512
+
+defaultPatienceForResults :: Double
+defaultPatienceForResults = 5
+
+prompt_ :: Repl -> Input -> IO ReplOutput
prompt_ r i = do
writeChan (inputChan r) i
readChan (outputChan r)
@@ -182,12 +187,11 @@ repl'
:: [String] -- ^ Imports, using normal Haskell import syntax
-> [ExtensionFlag] -- ^ List of compiler extensions to use
-> Chan Input -- ^ Input channel
- -> Chan Output -- ^ Output channel
+ -> Chan ReplOutput -- ^ Output channel
-> Maybe Double -- ^ Maximum time to wait for a result, in seconds (default: 5)
- -> Maybe Int -- ^ Maximum time to wait for an error, in microseconds (default: 3000)
-> Maybe Int -- ^ Maximum line length in 'Char' (default: 512)
-> IO Repl
-repl' imports exts inp out wait ewait len = do
+repl' imports exts inp out wait len = do
interp <- forkIO $
runGhc (Just libdir) $ do
dflags <- session
@@ -215,7 +219,7 @@ repl' imports exts inp out wait ewait len = do
return $ Output []
Type s -> errors $ formatType <$> exprType s
Kind s -> errors $ formatType . snd <$> typeKind True s
- Decl s -> errors $ do runDecls s; return $ Output ["OK."]
+ Decl s -> errors $ do _names <- runDecls s; return $ Output ["OK."]
Bind s -> errors $ do void (runStmt ("let {" ++ s ++ "}") SingleStep); return $ Output ["OK."]
Expr s -> errors $ do
compiled <- dynCompileExpr $ "show (" ++ s ++ ")"
@@ -226,7 +230,7 @@ repl' imports exts inp out wait ewait len = do
. catMaybes
<$> mapM getInfo names
return $ Output infos
- return $ Repl inp out interp wait ewait len
+ return $ Repl inp out interp (fromMaybe defaultPatienceForResults wait) (fromMaybe defaultLineLength len)
where
errors x = x `gcatch` \ e@SomeException{} ->
case fromException e :: Maybe ErrorCall of

0 comments on commit b690371

Please sign in to comment.
Something went wrong with that request. Please try again.