diff --git a/repl.cabal b/repl.cabal --- a/repl.cabal +++ b/repl.cabal @@ -1,5 +1,5 @@ name: repl -version: 0.92 +version: 0.95 synopsis: IRC friendly REPL library. description: IRC friendly REPL library. Similar to mueval, but implemented as a server using the GHC API, making it diff --git a/src/Language/Haskell/Repl.hs b/src/Language/Haskell/Repl.hs --- a/src/Language/Haskell/Repl.hs +++ b/src/Language/Haskell/Repl.hs @@ -7,7 +7,7 @@ , defaultExtensions , defaultImports , defaultLineLength - , defaultPatienceForResults + , defaultPatience -- * Stopping , stopRepl -- * Interaction @@ -42,6 +42,16 @@ import GhcMonad import Outputable (showSDocForUser, Outputable, ppr, neverQualify) +data Repl a = Repl + { inputChan :: Chan Input + , outputChan :: Chan (ReplOutput a) + , interpreter :: ThreadId + , processOutput :: Dynamic -> IO a + , buildExpr :: String -> String + , patience :: Double + , lineLength :: Int + } + data Input = Type String | Kind String @@ -53,10 +63,11 @@ | Clear deriving Show -data ReplOutput +data ReplOutput a = ReplError String | GhcError String | Output [String] + | Result a-- [String] deriving Show data Output @@ -121,22 +132,14 @@ prettyOutput (Partial s) = overLast (++ "*** Timed out") s prettyOutput Timeout = ["*** Timed out"] -data Repl = Repl - { inputChan :: Chan Input - , outputChan :: Chan ReplOutput - , interpreter :: ThreadId - , patienceForResult :: Double - , lineLength :: Int - } - -- | Send input. -input :: Repl -> Input -> IO () +input :: Repl a -> Input -> IO () input = writeChan . inputChan -- | Naiively get the next set of results. This /does not/ take into account --- 'patienceForResults', 'patienceForErrors', or 'lineLength'. However, due +-- 'patiences', 'patienceForErrors', or 'lineLength'. However, due -- to laziness, this may not matter. -output :: Repl -> IO ReplOutput +output :: Repl a -> IO (ReplOutput a) output = readChan . outputChan {-# INLINE (!?) #-} @@ -160,7 +163,7 @@ -- | Same as 'prompt_', except it parses the input, and pretty prints the results. prompt - :: Repl + :: Repl [String] -> String -> IO [String] prompt repl x = prettyOutput <$> prompt_ repl (case runParser parseInput () "" x of @@ -172,7 +175,7 @@ -- However, truncate input to the given length, and stop the computation after the -- given amount of time in seconds. prompt_ - :: Repl + :: Repl [String] -> Input -> IO Output prompt_ repl x = do @@ -200,11 +203,11 @@ fork $ forM_ ys $ \_ -> modifyIORef acc (\i -> if i > lineLength repl then i else i+1) return acc - unlessError results $ \ res -> do + unlessRedundant results $ \ res -> do -- Time out fork $ do - threadDelay (floor (patienceForResult repl*1000000)) + threadDelay (floor (patience repl*1000000)) u <- readOutputs case res !? length u of Nothing -> putMVar final (if null u then Timeout else Partial u) @@ -231,18 +234,27 @@ 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 + -- | Don't bother with things other than an actual result from an expression -- they will be loaded "instantly" + unlessRedundant (ReplError s) _ = return . Errors . map trim . lines $ s + unlessRedundant (GhcError s) _ = return . Errors . map trim . lines $ s + unlessRedundant (Output s) _ = return . OK . map trim $ s + unlessRedundant (Result s) f = f s -stopRepl :: Repl -> IO () +stopRepl :: Repl a -> IO () stopRepl = killThread . interpreter -newRepl :: IO Repl +-- | Default GHCi-like 'Repl' +newRepl :: IO (Repl [String]) newRepl = do inp <- newChan out <- newChan - repl' defaultImports defaultExtensions inp out Nothing Nothing + repl' inp out + defaultImports + defaultExtensions + defaultBuildExpr + defaultProcessOutput + defaultPatience + defaultLineLength defaultImports :: [String] defaultImports @@ -273,7 +285,7 @@ ,"import Data.Maybe" ,"import Data.Semigroup" ,"import Data.Bits" - ,"import Data.Bits.Lens" + ,"import Data.Array" ,"import Data.Ix" ,"import Data.Functor" ,"import Data.Typeable" @@ -302,22 +314,32 @@ ,Opt_FunctionalDependencies ,Opt_GADTs] +-- | defaultLineLength = 512 defaultLineLength :: Int defaultLineLength = 512 -defaultPatienceForResults :: Double -defaultPatienceForResults = 5 +-- | defaultPatience = 5 +defaultPatience :: Double +defaultPatience = 5 +defaultBuildExpr :: String -> String +defaultBuildExpr x = "show (" ++ x ++ ")" + +defaultProcessOutput :: Dynamic -> IO [String] +defaultProcessOutput d = return (lines (fromDyn d "")) + -- | 'Repl' smart constructor. repl' - :: [String] -- ^ Imports, using normal Haskell import syntax - -> [ExtensionFlag] -- ^ List of compiler extensions to use - -> Chan Input -- ^ Input channel - -> Chan ReplOutput -- ^ Output channel - -> Maybe Double -- ^ Maximum time to wait for a result, in seconds (default: 5) - -> Maybe Int -- ^ Maximum line length in 'Char' (default: 512) - -> IO Repl -repl' imports exts inp out wait len = do + :: Chan Input -- ^ Input channel + -> Chan (ReplOutput a) -- ^ Output channel + -> [String] -- ^ Imports, using normal Haskell import syntax + -> [ExtensionFlag] -- ^ List of compiler extensions to use + -> (String -> String) -- ^ Used to build the expression actually sent to GHC + -> (Dynamic -> IO a) -- ^ Used to send output to the output 'Chan'. + -> Double -- ^ Maximum time to wait for a result, in seconds + -> Int -- ^ Maximum line length in 'Char' + -> IO (Repl a) +repl' inp out imports exts build process wait len = do interp <- forkIO $ runGhc (Just libdir) $ do dflags <- session @@ -338,22 +360,31 @@ Clear -> do setTargets [] void (load LoadAllTargets) - return $ Output ["OK, I forgot everything."] - Undefine _ -> return $ Output ["Not implemented yet."] + return (Output ["Cleared memory."]) + Undefine _ -> return (ReplError "Not implemeneted") Type s -> errors $ formatType <$> exprType s Kind s -> errors $ formatType . snd <$> typeKind True s - Decl s -> errors $ do _names <- runDecls s; return $ Output ["OK."] - Stmt s -> errors $ do void (runStmt s SingleStep); return $ Output ["OK."] + Decl s -> errors $ do _names <- runDecls s; return (Output ["OK."]) -- ["OK."] + Stmt s -> errors $ do void (runStmt s SingleStep); return (Output ["OK."]) Expr s -> errors $ do - compiled <- dynCompileExpr $ "show (" ++ s ++ ")" - return $ Output [fromDyn compiled ""] + compiled <- dynCompileExpr (build s) + built <- liftIO (process compiled) + return (Result built) Info s -> errors $ do names <- parseName s infos <- concatMap (\(t,f,cs) -> sdoc t : sdoc f : map sdoc cs) . catMaybes <$> mapM getInfo names return $ Output infos - return $ Repl inp out interp (fromMaybe defaultPatienceForResults wait) (fromMaybe defaultLineLength len) + return Repl + { inputChan = inp + , outputChan = out + , interpreter = interp + , processOutput = process + , buildExpr = build + , patience = wait + , lineLength = len + } where errors x = x `gcatch` \ e@SomeException{} -> case fromException e :: Maybe ErrorCall of