Skip to content

Commit

Permalink
allow a polymorphic output
Browse files Browse the repository at this point in the history
  • Loading branch information
@mikeplus64
mikeplus64 committed Jan 31, 2013
1 parent 0d3f246 commit 22efc91
Show file tree
Hide file tree
Showing 2 changed files with 73 additions and 42 deletions.
2 changes: 1 addition & 1 deletion repl.cabal
View file
@@ -1,5 +1,5 @@
name: repl name: repl
version: 0.92 version: 0.95
synopsis: IRC friendly REPL library. synopsis: IRC friendly REPL library.
description: IRC friendly REPL library. Similar to mueval, but description: IRC friendly REPL library. Similar to mueval, but
implemented as a server using the GHC API, making it implemented as a server using the GHC API, making it
Expand Down
113 changes: 72 additions & 41 deletions src/Language/Haskell/Repl.hs
View file
Expand Up @@ -7,7 +7,7 @@ module Language.Haskell.Repl
, defaultExtensions , defaultExtensions
, defaultImports , defaultImports
, defaultLineLength , defaultLineLength
, defaultPatienceForResults , defaultPatience
-- * Stopping -- * Stopping
, stopRepl , stopRepl
-- * Interaction -- * Interaction
Expand Down Expand Up @@ -42,6 +42,16 @@ import DynFlags
import GhcMonad import GhcMonad
import Outputable (showSDocForUser, Outputable, ppr, neverQualify) 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 data Input
= Type String = Type String
| Kind String | Kind String
Expand All @@ -53,10 +63,11 @@ data Input
| Clear | Clear
deriving Show deriving Show


data ReplOutput data ReplOutput a
= ReplError String = ReplError String
| GhcError String | GhcError String
| Output [String] | Output [String]
| Result a-- [String]
deriving Show deriving Show


data Output data Output
Expand Down Expand Up @@ -121,22 +132,14 @@ prettyOutput (Errors errs) = errs
prettyOutput (Partial s) = overLast (++ "*** Timed out") s prettyOutput (Partial s) = overLast (++ "*** Timed out") s
prettyOutput Timeout = ["*** Timed out"] prettyOutput Timeout = ["*** Timed out"]


data Repl = Repl
{ inputChan :: Chan Input
, outputChan :: Chan ReplOutput
, interpreter :: ThreadId
, patienceForResult :: Double
, lineLength :: Int
}

-- | Send input. -- | Send input.
input :: Repl -> Input -> IO () input :: Repl a -> Input -> IO ()
input = writeChan . inputChan input = writeChan . inputChan


-- | Naiively get the next set of results. This /does not/ take into account -- | 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. -- to laziness, this may not matter.
output :: Repl -> IO ReplOutput output :: Repl a -> IO (ReplOutput a)
output = readChan . outputChan output = readChan . outputChan


{-# INLINE (!?) #-} {-# INLINE (!?) #-}
Expand All @@ -160,7 +163,7 @@ overLast f = go


-- | Same as 'prompt_', except it parses the input, and pretty prints the results. -- | Same as 'prompt_', except it parses the input, and pretty prints the results.
prompt prompt
:: Repl :: Repl [String]
-> String -> String
-> IO [String] -> IO [String]
prompt repl x = prettyOutput <$> prompt_ repl (case runParser parseInput () "" x of prompt repl x = prettyOutput <$> prompt_ repl (case runParser parseInput () "" x of
Expand All @@ -172,7 +175,7 @@ prompt repl x = prettyOutput <$> prompt_ repl (case runParser parseInput () "" x
-- However, truncate input to the given length, and stop the computation after the -- However, truncate input to the given length, and stop the computation after the
-- given amount of time in seconds. -- given amount of time in seconds.
prompt_ prompt_
:: Repl :: Repl [String]
-> Input -> Input
-> IO Output -> IO Output
prompt_ repl x = do prompt_ repl x = do
Expand Down Expand Up @@ -200,11 +203,11 @@ prompt_ repl x = do
fork $ forM_ ys $ \_ -> modifyIORef acc (\i -> if i > lineLength repl then i else i+1) fork $ forM_ ys $ \_ -> modifyIORef acc (\i -> if i > lineLength repl then i else i+1)
return acc return acc


unlessError results $ \ res -> do unlessRedundant results $ \ res -> do


-- Time out -- Time out
fork $ do fork $ do
threadDelay (floor (patienceForResult repl*1000000)) threadDelay (floor (patience repl*1000000))
u <- readOutputs u <- readOutputs
case res !? length u of case res !? length u of
Nothing -> putMVar final (if null u then Timeout else Partial u) Nothing -> putMVar final (if null u then Timeout else Partial u)
Expand All @@ -231,18 +234,27 @@ prompt_ repl x = do
where where
trim = take (lineLength repl) trim = take (lineLength repl)


unlessError (ReplError s) _ = return . Errors . map trim . lines $ s -- | Don't bother with things other than an actual result from an expression -- they will be loaded "instantly"
unlessError (GhcError s) _ = return . Errors . map trim . lines $ s unlessRedundant (ReplError s) _ = return . Errors . map trim . lines $ s
unlessError (Output s) f = f 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 stopRepl = killThread . interpreter


newRepl :: IO Repl -- | Default GHCi-like 'Repl'
newRepl :: IO (Repl [String])
newRepl = do newRepl = do
inp <- newChan inp <- newChan
out <- newChan out <- newChan
repl' defaultImports defaultExtensions inp out Nothing Nothing repl' inp out
defaultImports
defaultExtensions
defaultBuildExpr
defaultProcessOutput
defaultPatience
defaultLineLength


defaultImports :: [String] defaultImports :: [String]
defaultImports defaultImports
Expand Down Expand Up @@ -273,7 +285,7 @@ defaultImports
,"import Data.Maybe" ,"import Data.Maybe"
,"import Data.Semigroup" ,"import Data.Semigroup"
,"import Data.Bits" ,"import Data.Bits"
,"import Data.Bits.Lens" ,"import Data.Array"
,"import Data.Ix" ,"import Data.Ix"
,"import Data.Functor" ,"import Data.Functor"
,"import Data.Typeable" ,"import Data.Typeable"
Expand Down Expand Up @@ -302,22 +314,32 @@ defaultExtensions
,Opt_FunctionalDependencies ,Opt_FunctionalDependencies
,Opt_GADTs] ,Opt_GADTs]


-- | defaultLineLength = 512
defaultLineLength :: Int defaultLineLength :: Int
defaultLineLength = 512 defaultLineLength = 512


defaultPatienceForResults :: Double -- | defaultPatience = 5
defaultPatienceForResults = 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' smart constructor.
repl' repl'
:: [String] -- ^ Imports, using normal Haskell import syntax :: Chan Input -- ^ Input channel
-> [ExtensionFlag] -- ^ List of compiler extensions to use -> Chan (ReplOutput a) -- ^ Output channel
-> Chan Input -- ^ Input channel -> [String] -- ^ Imports, using normal Haskell import syntax
-> Chan ReplOutput -- ^ Output channel -> [ExtensionFlag] -- ^ List of compiler extensions to use
-> Maybe Double -- ^ Maximum time to wait for a result, in seconds (default: 5) -> (String -> String) -- ^ Used to build the expression actually sent to GHC
-> Maybe Int -- ^ Maximum line length in 'Char' (default: 512) -> (Dynamic -> IO a) -- ^ Used to send output to the output 'Chan'.
-> IO Repl -> Double -- ^ Maximum time to wait for a result, in seconds
repl' imports exts inp out wait len = do -> Int -- ^ Maximum line length in 'Char'
-> IO (Repl a)
repl' inp out imports exts build process wait len = do
interp <- forkIO $ interp <- forkIO $
runGhc (Just libdir) $ do runGhc (Just libdir) $ do
dflags <- session dflags <- session
Expand All @@ -338,22 +360,31 @@ repl' imports exts inp out wait len = do
Clear -> do Clear -> do
setTargets [] setTargets []
void (load LoadAllTargets) void (load LoadAllTargets)
return $ Output ["OK, I forgot everything."] return (Output ["Cleared memory."])
Undefine _ -> return $ Output ["Not implemented yet."] Undefine _ -> return (ReplError "Not implemeneted")
Type s -> errors $ formatType <$> exprType s Type s -> errors $ formatType <$> exprType s
Kind s -> errors $ formatType . snd <$> typeKind True s Kind s -> errors $ formatType . snd <$> typeKind True s
Decl s -> errors $ do _names <- runDecls s; 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."] Stmt s -> errors $ do void (runStmt s SingleStep); return (Output ["OK."])
Expr s -> errors $ do Expr s -> errors $ do
compiled <- dynCompileExpr $ "show (" ++ s ++ ")" compiled <- dynCompileExpr (build s)
return $ Output [fromDyn compiled ""] built <- liftIO (process compiled)
return (Result built)
Info s -> errors $ do Info s -> errors $ do
names <- parseName s names <- parseName s
infos <- concatMap (\(t,f,cs) -> sdoc t : sdoc f : map sdoc cs) infos <- concatMap (\(t,f,cs) -> sdoc t : sdoc f : map sdoc cs)
. catMaybes . catMaybes
<$> mapM getInfo names <$> mapM getInfo names
return $ Output infos 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 where
errors x = x `gcatch` \ e@SomeException{} -> errors x = x `gcatch` \ e@SomeException{} ->
case fromException e :: Maybe ErrorCall of case fromException e :: Maybe ErrorCall of
Expand Down

0 comments on commit 22efc91

Please sign in to comment.