module Language.Haskell.Repl
( Repl
, newRepl
, repl'
, defaultFlags
, defaultImports
, defaultLineLength
, defaultPatience
, defaultBuildExpr
, defaultProcessOutput
, stopRepl
, Input(..)
, ReplOutput(..)
, Output(..)
, prompt
, prompt_
, send
, result
, prettyOutput
, parseInput
) where
import Control.Concurrent
import Control.Applicative ((<$>))
import Control.Exception (catch, SomeException(..), ErrorCall(..), fromException, Exception(..), evaluate)
import Control.Monad
import Control.Arrow
import Data.Dynamic
import Data.IORef
import Data.Char (isAscii)
import Data.Maybe
import Text.Parsec hiding (newline)
import Text.Parsec.String
import qualified Language.Haskell.Exts as H
import GHC
import GHC.Paths
import GhcMonad
import Outputable (showSDocForUser, Outputable, ppr, neverQualify)
import HscTypes
import OccName
import System.IO.Unsafe
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
| Info String
| Decl String
| Stmt String
| Expr String
| Undefine String
| Clear
deriving Show
data ReplOutput a
= ReplError String
| GhcError String
| Output [String]
| Result a
deriving Show
data Output
= OK [String]
| Exception [String] String
| Errors [String]
| Partial [String]
| Timeout [String]
deriving Show
prefix :: String -> Parser ()
prefix (x:xs) = do
_ <- string [':',x]
forM_ xs (optional . char)
spaces
prefix [] = fail "empty prefix"
simpl :: String -> (String -> a) -> Parser a
simpl pfix f = do
prefix pfix
f <$> getInput
parseType, parseKind, parseInfo, parseDecl, parseStmt, parseExpr, parseUndefine, parseClear, parseInput :: Parser Input
parseType = simpl "type" Type
parseKind = simpl "kind" Kind
parseInfo = simpl "info" Info
parseUndefine = simpl "undef" Undefine
parseClear = simpl "clear" (const Clear)
parseDecl = do
p <- single ["class ","type ","data ","newtype ","instance ","deriving ","foreign ","default(","default "]
r <- getInput
return (Decl (p ++ r))
where single = foldr1 (<|>) . map (try . string)
parseStmt = do
stmt <- getInput
case H.parseStmt stmt of
H.ParseOk H.LetStmt{}
-> return (Stmt stmt)
_ -> case H.parseStmt (mangle stmt) of
H.ParseOk H.LetStmt{}
-> return (Stmt stmt)
_ -> fail "Not a let binding."
where
mangle = map $ \c -> if isAscii c then c else 'x'
parseExpr = Expr <$> getInput
parseInput = foldr1 (\l r -> Text.Parsec.try l <|> r)
[ parseClear
, parseUndefine
, parseType
, parseKind
, parseInfo
, parseStmt
, parseDecl
, parseExpr ]
unsafeCatch :: Exception e => a -> (e -> a) -> a
unsafeCatch a f = unsafePerformIO (catch (evaluate a) (return . f))
cripple :: a -> a -> a
cripple x y = unsafeCatch x (\SomeException{} -> y)
prettyOutput :: Repl a -> Output -> [String]
prettyOutput _ (OK s) = s
prettyOutput _ (Partial s) = s
prettyOutput _ (Errors errs) = errs
prettyOutput r (Exception s e) = map
(take (lineLength r))
(overLast (++ ("*** Exception: " ++ cripple e "*** Exception: that's enough exceptions for you.")) s)
prettyOutput _ (Timeout []) = ["*** Timed out"]
prettyOutput _ (Timeout s) = overLast (++ "*** Timed out") s
send :: Repl a -> Input -> IO ()
send = writeChan . inputChan
result :: Repl a -> IO (ReplOutput a)
result = readChan . outputChan
index :: Int -> [a] -> Maybe a
i `index` ys
| i >= 0 = go 0 ys
| otherwise = Nothing
where
go _ [] = Nothing
go j (x:xs)
| j == i = Just x
| otherwise = go (j+1) xs
overHead :: (a -> a) -> [a] -> [a]
overHead f xs' = case xs' of
x:xs -> f x : xs
_ -> []
overLast :: (a -> a) -> [a] -> [a]
overLast f = go
where
go [] = []
go [x] = [f x]
go (x:xs) = x : go xs
lengthAt :: Int -> [[a]] -> Int
lengthAt i = maybe 0 length . index i
prompt
:: Repl [String]
-> String
-> IO [String]
prompt repl x = prettyOutput repl <$> prompt_ repl (case runParser parseInput () "" x of
Right a -> a
_ -> error "Cannot parse input!")
prompt_
:: Repl [String]
-> Input
-> IO Output
prompt_ repl x = do
send repl x
results' <- result repl
unlessRedundant results' $ \ results -> do
outputs :: IORef [String] <- newIORef []
threads :: IORef [ThreadId] <- newIORef []
final :: MVar Output <- newEmptyMVar
let push c = do
output <- readIORef outputs
if lengthAt (length output 1) output > lineLength repl
then putMVar final (Partial (unreverse output))
else writeIORef outputs (overHead (c:) output)
newline = modifyIORef outputs ([]:)
readOutput = unreverse <$> readIORef outputs
fork f = do
thread <- forkIO $ f `catch` \e@SomeException{} -> do
output <- readOutput
putMVar final (Exception output (show e))
modifyIORef threads (thread:)
fork $ do
threadDelay (floor (patience repl * 1000000))
output <- readOutput
putMVar final (Timeout output)
fork $ do
forM_ results $ \l -> do
newline
forM_ l push
putMVar final . OK =<< readOutput
output <- takeMVar final
mapM_ killThread =<< readIORef threads
return output
where
unreverse = reverse . map reverse
trim = take (lineLength repl)
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 a -> IO ()
stopRepl = killThread . interpreter
newRepl :: IO (Repl [String])
newRepl = do
inp <- newChan
out <- newChan
repl' inp out
defaultImports
defaultFlags
defaultBuildExpr
defaultProcessOutput
defaultPatience
defaultLineLength
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.List.Split"
,"import Data.Maybe"
,"import Data.Bits"
,"import Data.Array"
,"import Data.Ix"
,"import Data.Functor"
,"import Data.Typeable"
,"import Data.Monoid"
,"import Data.Ratio"
,"import Data.Complex"
,"import Data.Char"
,"import Data.Bits.Lens"
,"import Data.List.Lens"
,"import Data.List.Split.Lens"
]
defaultFlags :: [String]
defaultFlags = map ("-X"++)
["DataKinds"
,"PolyKinds"
,"KindSignatures"
,"TypeOperators"
,"DeriveFunctor"
,"DeriveTraversable"
,"DeriveFoldable"
,"DeriveDataTypeable"
,"DeriveGeneric"
,"OverloadedStrings"
,"ImplicitParams"
,"BangPatterns"
,"PatternGuards"
,"MultiWayIf"
,"LambdaCase"
,"FlexibleInstances"
,"FlexibleContexts"
,"FunctionalDependencies"
,"StandaloneDeriving"
,"MultiParamTypeClasses"
,"UnicodeSyntax"
,"RankNTypes"
,"ExistentialQuantification"
,"GADTs"
,"TypeFamilies"
,"Safe"
] ++
[ "-dcore-lint" ]
defaultLineLength :: Int
defaultLineLength = 512
defaultPatience :: Double
defaultPatience = 5
defaultBuildExpr :: String -> String
defaultBuildExpr x = "show (" ++ x ++ ")"
defaultProcessOutput :: Dynamic -> IO [String]
defaultProcessOutput d = return (lines (fromDyn d ""))
repl'
:: Chan Input
-> Chan (ReplOutput a)
-> [String]
-> [String]
-> (String -> String)
-> (Dynamic -> IO a)
-> Double
-> Int
-> IO (Repl a)
repl' inp out imports compilerFlags build process wait len = do
interp <- forkIO $
runGhc (Just libdir) $ do
initialDynFlags <- getProgramDynFlags
(dflags',_,_) <- parseDynamicFlags initialDynFlags (map (mkGeneralLocated "flag") compilerFlags)
_pkgs <- setSessionDynFlags dflags'
dflags <- getSessionDynFlags
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 ["Cleared memory."])
Undefine s' -> fmap Output $
forM (words s') $ \s -> do
let eqs :: NamedThing a => a -> Bool
eqs n = occNameString (getOccName n) == s
session <- getSession
setSession session
{ hsc_IC = (hsc_IC session)
{ ic_tythings = filter (not . eqs) (ic_tythings (hsc_IC session)) }
}
return "OK."
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 (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
{ inputChan = inp
, outputChan = out
, interpreter = interp
, processOutput = process
, buildExpr = build
, patience = wait
, lineLength = len
}
where
errors x = x `gcatch` \ e@SomeException{} ->
return $! case fromException e :: Maybe ErrorCall of
Just _ -> ReplError (show e)
_ -> GhcError (show e)
import_ = mapM (fmap IIDecl . parseImportDecl) >=> setContext