module Language.Haskell.Repl
( Repl
, newRepl
, repl'
, defaultExtensions
, defaultImports
, defaultLineLength
, defaultPatienceForResults
, stopRepl
, Input(..)
, ReplOutput(..)
, Output(..)
, prompt
, prompt_
, input
, output
, prettyOutput
, parseInput
) where
import Control.Concurrent
import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Arrow
import Data.Dynamic
import Data.IORef
import Data.Maybe
import qualified Data.DList as DL
import Text.Parsec hiding (many,(<|>),newline)
import Text.Parsec.String
import qualified Language.Haskell.Exts.Parser as H
import qualified Language.Haskell.Exts.Syntax as H
import GHC
import GHC.Paths
import DynFlags
import GhcMonad
import Outputable (showSDocForUser, Outputable, ppr, neverQualify)
data Input
= Type String
| Kind String
| Info String
| Decl String
| Stmt String
| Expr String
| Undefine String
| Clear
deriving Show
data ReplOutput
= ReplError String
| GhcError String
| Output [String]
deriving Show
data Output
= OK [String]
| Exception [String] String
| Errors [String]
| Partial [String]
| Timeout
deriving Show
prefix :: Char -> Parser ()
prefix c = do
_ <- string [':',c]
spaces
input' :: Char -> (String -> Parser a) -> Parser a
input' p f = do
prefix p
f =<< getInput
simpl :: Char -> (String -> a) -> Parser a
simpl c f = input' c (return . f)
valid :: (String -> H.ParseResult a) -> String -> Bool
valid f x = case f x of
H.ParseOk _ -> True
_ -> False
parseType, parseKind, parseInfo, parseDecl, parseStmt, parseExpr, parseUndefine, parseClear, parseInput :: Parser Input
parseType = simpl 't' Type
parseKind = simpl 'k' Kind
parseInfo = simpl 'i' Info
parseDecl = do
decl <- getInput
guard (valid H.parseDecl decl)
return (Decl decl)
parseStmt = do
stmt <- getInput
case H.parseStmt stmt of
H.ParseOk (H.LetStmt _) -> return (Stmt stmt)
_ -> fail "Not a let binding."
parseExpr = Expr <$> getInput
parseUndefine = simpl 'd' Undefine
parseClear = simpl 'c' (const Clear)
parseInput = foldr1 (\l r -> Text.Parsec.try l <|> r)
[ parseClear
, parseUndefine
, parseType
, parseKind
, parseInfo
, parseStmt
, parseDecl
, parseExpr ]
prettyOutput :: Output -> [String]
prettyOutput (OK s) = s
prettyOutput (Exception s e) = overLast (++ ("*** Exception: " ++ e)) s
prettyOutput (Errors errs) = errs
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
}
input :: Repl -> Input -> IO ()
input = writeChan . inputChan
output :: Repl -> IO ReplOutput
output = readChan . outputChan
(!?) :: [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
overLast :: (a -> a) -> [a] -> [a]
overLast f = go
where
go [] = []
go [x] = [f x]
go (x:xs) = x : go xs
prompt
:: Repl
-> String
-> IO [String]
prompt repl x = prettyOutput <$> prompt_ repl (case runParser parseInput () "" x of
Right a -> a
_ -> error "Cannot parse input!")
prompt_
:: Repl
-> Input
-> IO Output
prompt_ repl x = do
input repl x
results <- output repl
threads <- newIORef []
final <- newEmptyMVar
outputs <- newIORef [] :: IO (IORef [DL.DList Char])
let readOutputs = map DL.toList <$> readIORef outputs
newline = modifyIORef outputs (++ [DL.empty])
push char' = modifyIORef outputs (overLast (`DL.snoc` char'))
fork f = do
t <- forkIO $ f `catch` \e@SomeException{} -> do
outs <- readOutputs
putMVar final (Exception outs (show e))
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
fork $ do
threadDelay (floor (patienceForResult repl*1000000))
u <- readOutputs
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 $ case take i h of
[] -> case u of
[] -> Timeout
_ -> Partial u
xs -> Partial (u ++ [xs])
fork $ do
let r = map trim res
forM_ r $ \l -> do
newline
forM_ l push
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
stopRepl :: Repl -> IO ()
stopRepl = killThread . interpreter
newRepl :: IO Repl
newRepl = do
inp <- newChan
out <- newChan
repl' defaultImports defaultExtensions inp out Nothing Nothing
defaultImports :: [String]
defaultImports
= ["import Prelude hiding ((.), id, catch)"
,"import GHC.TypeLits"
,"import qualified Data.Map as M"
,"import qualified Data.Foldable as F"
,"import qualified Data.Traversable as T"
,"import qualified Control.Exception (catch)"
,"import Control.Monad.Reader"
,"import Control.Monad.State"
,"import Control.Monad.Writer"
,"import Control.Monad.RWS"
,"import Control.Monad.Identity"
,"import Control.Monad.ST"
,"import Control.Comonad"
,"import Control.Category"
,"import Control.Monad"
,"import Control.Monad.Fix"
,"import Control.Applicative"
,"import Control.Lens"
,"import Control.Arrow"
,"import Data.Function hiding ((.), id)"
,"import Data.Either"
,"import Data.Int"
,"import Data.Word"
,"import Data.List"
,"import Data.Maybe"
,"import Data.Semigroup"
,"import Data.Bits"
,"import Data.Bits.Lens"
,"import Data.Ix"
,"import Data.Functor"
,"import Data.Typeable"
]
defaultExtensions :: [ExtensionFlag]
defaultExtensions
= [Opt_DataKinds
,Opt_PolyKinds
,Opt_KindSignatures
,Opt_TypeFamilies
,Opt_TypeOperators
,Opt_DeriveFunctor
,Opt_DeriveTraversable
,Opt_DeriveFoldable
,Opt_DeriveDataTypeable
,Opt_DeriveGeneric
,Opt_OverloadedStrings
,Opt_ImplicitParams
,Opt_BangPatterns
,Opt_PatternGuards
,Opt_MultiWayIf
,Opt_LambdaCase
,Opt_FlexibleInstances
,Opt_FlexibleContexts
,Opt_FunctionalDependencies
,Opt_GADTs]
defaultLineLength :: Int
defaultLineLength = 512
defaultPatienceForResults :: Double
defaultPatienceForResults = 5
repl'
:: [String]
-> [ExtensionFlag]
-> Chan Input
-> Chan ReplOutput
-> Maybe Double
-> Maybe Int
-> IO Repl
repl' imports exts inp out wait len = do
interp <- forkIO $
runGhc (Just libdir) $ do
dflags <- session
let sdoc :: Outputable a => a -> String
sdoc = showSDocForUser dflags neverQualify . ppr
formatType
= splitForAllTys
>>> snd
>>> sdoc
>>> lines
>>> Output
forever $ do
import_ imports
i' <- liftIO (readChan inp)
liftIO . writeChan out =<< case i' of
Clear -> do
setTargets []
void (load LoadAllTargets)
return $ Output ["OK, I forgot everything."]
Undefine _ -> return $ Output ["Not implemented yet."]
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."]
Expr s -> errors $ do
compiled <- dynCompileExpr $ "show (" ++ s ++ ")"
return $ Output [fromDyn compiled ""]
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)
where
errors x = x `gcatch` \ e@SomeException{} ->
case fromException e :: Maybe ErrorCall of
Just _ -> return $ ReplError (show e)
_ -> return $ GhcError (show e)
import_ = mapM (fmap IIDecl . parseImportDecl) >=> setContext
getExts = foldr (fmap . flip xopt_set) id
session = do
s <- getProgramDynFlags
_ <- setSessionDynFlags
$ (\d -> d { safeHaskell = Sf_Safe })
. flip dopt_set Opt_DoCoreLinting
$ getExts exts s
getSessionDynFlags