repl 0.95 → 1.1
raw patch · 2 files changed
+195/−144 lines, 2 filesdep −dlistdep ~ghc-pathsdep ~haskell-src-extsdep ~parsec
Dependencies removed: dlist
Dependency ranges changed: ghc-paths, haskell-src-exts, parsec
Files
- repl.cabal +8/−7
- src/Language/Haskell/Repl.hs +187/−137
repl.cabal view
@@ -1,14 +1,15 @@ name: repl-version: 0.95+version: 1.1 synopsis: IRC friendly REPL library.-description: IRC friendly REPL library. Similar to mueval, but- implemented as a server using the GHC API, making it- much faster than mueval.+description: + Similar to mueval, but using a server with the GHC API instead of a command-line tool.+ As a result, it is much faster than mueval.+ Additionally, repl supports declarations/bindings (and deleting them), type and kind pretty printing, in addition to expression evaluation. license: MIT license-file: LICENSE author: Mike Ledger-homepage: https://github.com/mikeplus64/repl maintainer: eleventynine@gmail.com+homepage: https://github.com/mikeplus64/repl category: Development build-type: Simple cabal-version: >=1.8@@ -18,6 +19,6 @@ location: https://github.com/mikeplus64/repl library- hs-source-dirs: src exposed-modules: Language.Haskell.Repl- build-depends: base == 4.6.*, ghc == 7.6.*, ghc-paths >= 0.1, dlist >= 0.5, parsec >= 3.1.3, haskell-src-exts >= 1.13.0+ build-depends: base ==4.6.*, parsec ==3.1.*, ghc == 7.6.*, haskell-src-exts ==1.13.*, ghc-paths ==0.1.*+ hs-source-dirs: src
src/Language/Haskell/Repl.hs view
@@ -4,10 +4,12 @@ -- * Construction , newRepl , repl'- , defaultExtensions+ , defaultFlags , defaultImports , defaultLineLength , defaultPatience+ , defaultBuildExpr+ , defaultProcessOutput -- * Stopping , stopRepl -- * Interaction@@ -16,31 +18,31 @@ , Output(..) , prompt , prompt_- , input- , output+ , send+ , result , prettyOutput , parseInput ) where import Control.Concurrent-import Control.Applicative-import Control.Exception+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 qualified Data.DList as DL-import Text.Parsec hiding (many,(<|>),newline)+import Text.Parsec hiding (newline) import Text.Parsec.String-import qualified Language.Haskell.Exts.Parser as H-import qualified Language.Haskell.Exts.Syntax as H-+import qualified Language.Haskell.Exts as H import GHC import GHC.Paths-import DynFlags import GhcMonad import Outputable (showSDocForUser, Outputable, ppr, neverQualify)+import HscTypes+import OccName+import System.IO.Unsafe data Repl a = Repl { inputChan :: Chan Input@@ -67,7 +69,7 @@ = ReplError String | GhcError String | Output [String]- | Result a-- [String]+ | Result a deriving Show data Output@@ -75,44 +77,54 @@ | Exception [String] String | Errors [String] | Partial [String]- | Timeout+ | Timeout [String] deriving Show -prefix :: Char -> Parser ()-prefix c = do- _ <- string [':',c]+prefix :: String -> Parser ()+prefix (x:xs) = do+ _ <- string [':',x]+ forM_ xs (optional . char) 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)+prefix [] = fail "empty prefix" -valid :: (String -> H.ParseResult a) -> String -> Bool-valid f x = case f x of- H.ParseOk _ -> True- _ -> False+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 't' Type-parseKind = simpl 'k' Kind-parseInfo = simpl 'i' Info-parseDecl = do- decl <- getInput- guard (valid H.parseDecl decl)- return (Decl decl)+parseType = simpl "type" Type+parseKind = simpl "kind" Kind+parseInfo = simpl "info" Info+parseUndefine = simpl "undef" Undefine+parseClear = simpl "clear" (const Clear)+parseDecl = do+ -- from InteractiveUI.hs+ 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+ -- Problem: a Stmt is automatically ran if it is :: IO a+ -- So we have to make sure it is a let binding.+ -- BUT haskell-src-exts can't handle Unicode in let bindings, so valid+ -- let bindings like "let あ = 0" get obliterated. Therefore, short of+ -- actually parsing the binding ourselves, we replaceanything not ASCII + -- with an ASCII character ('x'). 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)+ 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+ -- | Used by 'prompt' parseInput = foldr1 (\l r -> Text.Parsec.try l <|> r) [ parseClear@@ -124,27 +136,36 @@ , 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)+ -- | Used by 'prompt'.-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"]+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 input.-input :: Repl a -> Input -> IO ()-input = writeChan . inputChan+send :: Repl a -> Input -> IO ()+send = writeChan . inputChan -- | Naiively get the next set of results. This /does not/ take into account -- 'patiences', 'patienceForErrors', or 'lineLength'. However, due -- to laziness, this may not matter.-output :: Repl a -> IO (ReplOutput a)-output = readChan . outputChan+result :: Repl a -> IO (ReplOutput a)+result = readChan . outputChan -{-# INLINE (!?) #-}-(!?) :: [a] -> Int -> Maybe a-ys !? i +{-# INLINE index #-}+index :: Int -> [a] -> Maybe a+i `index` ys | i >= 0 = go 0 ys | otherwise = Nothing where@@ -153,6 +174,12 @@ | j == i = Just x | otherwise = go (j+1) xs +{-# INLINE overHead #-}+overHead :: (a -> a) -> [a] -> [a]+overHead f xs' = case xs' of+ x:xs -> f x : xs+ _ -> []+ {-# INLINE overLast #-} overLast :: (a -> a) -> [a] -> [a] overLast f = go@@ -161,12 +188,16 @@ go [x] = [f x] go (x:xs) = x : go xs +{-# INLINE lengthAt #-}+lengthAt :: Int -> [[a]] -> Int+lengthAt i = maybe 0 length . index i+ -- | Same as 'prompt_', except it parses the input, and pretty prints the results. prompt :: Repl [String] -> String -> IO [String]-prompt repl x = prettyOutput <$> prompt_ repl (case runParser parseInput () "" x of+prompt repl x = prettyOutput repl <$> prompt_ repl (case runParser parseInput () "" x of Right a -> a -- Should be impossible to reach. parseExpr gobbles up everything. _ -> error "Cannot parse input!")@@ -179,60 +210,49 @@ -> Input -> IO Output prompt_ repl x = do- input repl x- results <- output repl- threads <- newIORef []- final <- newEmptyMVar-- -- outputs is used iff an exception is raised by the compiled input.- 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:)-- -- Get the "progress" of a list.- prog ys = do- acc <- newIORef 0- fork $ forM_ ys $ \_ -> modifyIORef acc (\i -> if i > lineLength repl then i else i+1)- return acc+ send repl x+ results' <- result repl - unlessRedundant results $ \ res -> do+ unlessRedundant results' $ \ results -> do+ -- outputs is used iff an exception is raised by the compiled input.+ -- This was a DList, but I didn't find any real advantage of it over+ -- [String] -- snoc was cheap but toList very expensive.+ 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:) -- Time out+ -- This can return only Timeout <what was consumed so far> fork $ do- threadDelay (floor (patience 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])+ threadDelay (floor (patience repl * 1000000))+ output <- readOutput+ putMVar final (Timeout output) - -- Return everything+ -- Read characters off of results, and "push" them to outputs. fork $ do- let r = map trim res- forM_ r $ \l -> do+ forM_ results $ \l -> do newline forM_ l push- putMVar final (OK r)-- fin <- takeMVar final+ putMVar final . OK =<< readOutput+ + output <- takeMVar final mapM_ killThread =<< readIORef threads- return fin+ return output where- trim = take (lineLength repl)+ unreverse = reverse . map reverse+ trim = take (lineLength repl) -- | 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@@ -250,7 +270,7 @@ out <- newChan repl' inp out defaultImports - defaultExtensions + defaultFlags defaultBuildExpr defaultProcessOutput defaultPatience@@ -282,37 +302,52 @@ ,"import Data.Int" ,"import Data.Word" ,"import Data.List"+ ,"import Data.List.Split" ,"import Data.Maybe"- ,"import Data.Semigroup" ,"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" ] -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]+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 = 512 defaultLineLength :: Int@@ -333,16 +368,20 @@ :: Chan Input -- ^ Input channel -> Chan (ReplOutput a) -- ^ Output channel -> [String] -- ^ Imports, using normal Haskell import syntax- -> [ExtensionFlag] -- ^ List of compiler extensions to use+ -> [String] -- ^ List of compiler flags -> (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+repl' inp out imports compilerFlags build process wait len = do interp <- forkIO $ runGhc (Just libdir) $ do- dflags <- session+ 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 @@ -355,13 +394,24 @@ forever $ do import_ imports- i' <- liftIO (readChan inp)+ i' <- liftIO (readChan inp) liftIO . writeChan out =<< case i' of Clear -> do setTargets [] void (load LoadAllTargets) return (Output ["Cleared memory."])- Undefine _ -> return (ReplError "Not implemeneted")++ 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."]) -- ["OK."]@@ -387,18 +437,18 @@ } where errors x = x `gcatch` \ e@SomeException{} -> - case fromException e :: Maybe ErrorCall of- Just _ -> return $ ReplError (show e)- _ -> return $ GhcError (show e)+ return $! case fromException e :: Maybe ErrorCall of+ Just _ -> ReplError (show e)+ _ -> GhcError (show e) import_ = mapM (fmap IIDecl . parseImportDecl) >=> setContext+ {- getExts = foldr (fmap . flip xopt_set) id- session = do+ mkSession = do s <- getProgramDynFlags- _ <- setSessionDynFlags - $ (\d -> d { safeHaskell = Sf_Safe })- . flip dopt_set Opt_DoCoreLinting - $ getExts exts s-- getSessionDynFlags+ let ds = getExts exts+ . flip dopt_set Opt_DoCoreLinting + . (\d -> d { safeHaskell = Sf_Safe })+ setSessionDynFlags (ds s)+ -}