diff --git a/repl.cabal b/repl.cabal --- a/repl.cabal +++ b/repl.cabal @@ -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 diff --git a/src/Language/Haskell/Repl.hs b/src/Language/Haskell/Repl.hs --- a/src/Language/Haskell/Repl.hs +++ b/src/Language/Haskell/Repl.hs @@ -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 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) + -}