Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: mikeplus64/repl
base: c02f476951
...
head fork: mikeplus64/repl
compare: de08f187fc
Checking mergeability… Don't worry, you can still create the pull request.
  • 4 commits
  • 4 files changed
  • 0 commit comments
  • 1 contributor
Showing with 127 additions and 76 deletions.
  1. +45 −0 Test.hs
  2. +8 −7 repl.cabal
  3. +74 −61 src/Language/Haskell/Repl.hs
  4. +0 −8 src/Test.hs
View
45 Test.hs
@@ -0,0 +1,45 @@
+import Language.Haskell.Repl
+import Control.Monad
+
+(-->) = (,)
+
+main :: IO ()
+main = do
+ repl <- newRepl
+ putStrLn "Started repl..."
+ let test label ts = do
+ putStrLn $ "--- " ++ label ++ " ---"
+ mapM_ (\(l,x') -> do x <- prompt repl x'; putStr $ l ++ ": "; mapM_ putStrLn x) ts
+
+ test "Expressions"
+ [ "quickly return" --> "let x = 32 in x"
+ , "quickly consume a line" --> "[0..]"
+ , "time out" --> "forever (return ()) :: Maybe ()"
+ , "time out and show output" --> "[0,1,2,3,let x = x in x]"
+ , "complete quickly and error" --> "[0,1,2,3,error \"yikes\"]"
+ ]
+
+ test "Declarations"
+ [ "datatypes" --> "data X = X deriving Show"
+ , "newtypes" --> "newtype X' = X' X"
+ , "types" --> "type Y = X"
+ , "classes" --> "class Abc a b | a -> b"
+ , "instances" --> "instance Abc X X'"
+ , "let-bindings" --> "let x = X; x' = X' x"
+ ]
+
+ test "Types"
+ [ "x :: X" --> ":t x"
+ , "fmapfmapfmap" --> ":t fmap fmap fmap"
+ ]
+
+ test "Kinds"
+ [ ":k X" --> ":k X"
+ ]
+
+ test "Misc"
+ [ "info" --> ":i Monoid"
+ , "undefining" --> ":d x'"
+ , "clear" --> ":c"
+ , "(try to get something)" --> ":t X"
+ ]
View
15 repl.cabal
@@ -1,14 +1,15 @@
name: repl
-version: 0.95
+version: 0.99
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 @@ source-repository head
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
View
135 src/Language/Haskell/Repl.hs
@@ -16,8 +16,8 @@ module Language.Haskell.Repl
, Output(..)
, prompt
, prompt_
- , input
- , output
+ , send
+ , result
, prettyOutput
, parseInput
) where
@@ -30,11 +30,12 @@ import Control.Arrow
import Data.Dynamic
import Data.IORef
import Data.Maybe
-import qualified Data.DList as DL
+import Data.List
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 qualified Language.Haskell.Exts.Extension as H
import GHC
import GHC.Paths
@@ -77,7 +78,7 @@ data Output
| Exception [String] String
| Errors [String]
| Partial [String]
- | Timeout
+ | Timeout [String]
deriving Show
prefix :: Char -> Parser ()
@@ -98,17 +99,32 @@ valid f x = case f x of
H.ParseOk _ -> True
_ -> False
+parseMode :: H.ParseMode
+parseMode = H.defaultParseMode
+ { H.extensions = H.knownExtensions \\
+ [ H.TemplateHaskell
+ , H.CPP
+ , H.ForeignFunctionInterface
+ , H.UnliftedFFITypes
+ , H.XmlSyntax
+ , H.MagicHash
+ , H.HereDocuments
+ , H.QuasiQuotes
+ , H.NPlusKPatterns
+ , H.UnboxedTuples ]
+ }
+
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)
+ guard (valid (H.parseDeclWithMode parseMode) decl)
return (Decl decl)
parseStmt = do
stmt <- getInput
- case H.parseStmt stmt of
+ case H.parseStmtWithMode parseMode stmt of
H.ParseOk (H.LetStmt _) -> return (Stmt stmt)
_ -> fail "Not a let binding."
parseExpr = Expr <$> getInput
@@ -129,24 +145,25 @@ parseInput = foldr1 (\l r -> Text.Parsec.try l <|> r)
-- | Used by 'prompt'.
prettyOutput :: Output -> [String]
prettyOutput (OK s) = s
-prettyOutput (Exception s e) = overLast (++ ("*** Exception: " ++ e)) s
+prettyOutput (Partial s) = s
prettyOutput (Errors errs) = errs
-prettyOutput (Partial s) = overLast (++ "*** Timed out") s
-prettyOutput Timeout = ["*** Timed out"]
+prettyOutput (Exception s e) = overLast (++ ("*** Exception: " ++ e)) 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
@@ -155,6 +172,12 @@ ys !? i
| 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
@@ -163,6 +186,10 @@ overLast f = go
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]
@@ -181,58 +208,44 @@ prompt_
-> 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
-
- unlessRedundant results $ \ res -> do
+ send repl x
+ results' <- result repl
+
+ 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 output)
+ else writeIORef outputs (overHead (c:) output)
+ newline = modifyIORef outputs ([]:)
+ readOutput = reverse . map reverse <$> 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])
-
- -- Return everything
+ threadDelay (floor (patience repl * 1000000))
+ output <- readOutput
+ putMVar final (Timeout output)
+
+ -- 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)
+ putMVar final . OK =<< readIORef outputs
- fin <- takeMVar final
- mapM_ killThread =<< readIORef threads
- return fin
+ takeMVar final
where
trim = take (lineLength repl)
View
8 src/Test.hs
@@ -1,8 +0,0 @@
-import Language.Haskell.Repl
-import Control.Monad
-main :: IO ()
-main = do
- r <- newRepl
- forever $ do
- l <- getLine
- promptWith r putStrLn [] l

No commit comments for this range

Something went wrong with that request. Please try again.