Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
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: d8e436edae
...
head fork: mikeplus64/repl
compare: e6792a12d7
  • 5 commits
  • 3 files changed
  • 0 commit comments
  • 1 contributor
Showing with 131 additions and 100 deletions.
  1. +10 −1 Test.hs
  2. +1 −1  repl.cabal
  3. +120 −98 src/Language/Haskell/Repl.hs
View
11 Test.hs
@@ -1,5 +1,6 @@
import Language.Haskell.Repl
+(-->) :: a -> b -> (a,b)
(-->) = (,)
main :: IO ()
@@ -8,7 +9,12 @@ main = do
putStrLn "Started repl..."
let test label ts = do
putStrLn $ "--- " ++ label ++ " ---"
- mapM_ (\(l,x') -> do x <- prompt repl x'; putStr $ l ++ ": "; mapM_ putStrLn x) ts
+ mapM_
+ (\(l,x') -> do
+ x <- prompt repl x'
+ putStr $ l ++ ": "
+ mapM_ putStrLn x)
+ ts
test "Expressions"
[ "quickly return" --> "let x = 32 in x"
@@ -16,6 +22,7 @@ main = do
, "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\"]"
+ , "unicode string" --> "let (⧺) = (++) in \"aaaa\" ⧺ \"私はバンゴホルーです。\" :: String"
]
test "Declarations"
@@ -26,10 +33,12 @@ main = do
, "instances" --> "instance Abc X X'"
, "let-bindings" --> "let x = X; x' = X' x"
, "normal binding (should fail)"--> "asdf = 31"
+ , "unicode let binding" --> "let あ = 'a'"
]
test "Types"
[ "x :: X" --> ":t x"
+ , ":t あ" --> ":t あ"
, "fmapfmapfmap" --> ":t fmap fmap fmap"
]
View
2  repl.cabal
@@ -1,5 +1,5 @@
name: repl
-version: 0.99
+version: 1.1
synopsis: IRC friendly REPL library.
description:
Similar to mueval, but using a server with the GHC API instead of a command-line tool.
View
218 src/Language/Haskell/Repl.hs
@@ -4,10 +4,12 @@ module Language.Haskell.Repl
-- * Construction
, newRepl
, repl'
- , defaultExtensions
+ , defaultFlags
, defaultImports
, defaultLineLength
, defaultPatience
+ , defaultBuildExpr
+ , defaultProcessOutput
-- * Stopping
, stopRepl
-- * Interaction
@@ -23,27 +25,24 @@ module Language.Haskell.Repl
) 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 Data.List
-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.Extension 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
@@ -70,7 +69,7 @@ data ReplOutput a
= ReplError String
| GhcError String
| Output [String]
- | Result a-- [String]
+ | Result a
deriving Show
data Output
@@ -81,52 +80,50 @@ data Output
| 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
+prefix [] = fail "empty prefix"
-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)
-
-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 ]
- }
+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
- case H.parseDeclWithMode parseMode decl of
- H.ParseOk H.PatBind{} -> fail "Use a let-binding."
- H.ParseOk _ -> return (Decl decl)
- _ -> fail "Not a declaration"
+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.parseStmtWithMode parseMode 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)
+ 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
-- | Used by 'prompt'
parseInput = foldr1 (\l r -> Text.Parsec.try l <|> r)
@@ -139,14 +136,22 @@ parseInput = foldr1 (\l r -> Text.Parsec.try l <|> r)
, 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 (Partial s) = s
-prettyOutput (Errors errs) = errs
-prettyOutput (Exception s e) = overLast (++ ("*** Exception: " ++ e)) s
-prettyOutput (Timeout []) = ["*** Timed out"]
-prettyOutput (Timeout s) = overLast (++ "*** Timed out") s
+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.
send :: Repl a -> Input -> IO ()
@@ -192,7 +197,7 @@ 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!")
@@ -240,7 +245,7 @@ prompt_ repl x = do
forM_ results $ \l -> do
newline
forM_ l push
- putMVar final . OK =<< readIORef outputs
+ putMVar final . OK =<< readOutput
output <- takeMVar final
mapM_ killThread =<< readIORef threads
@@ -265,7 +270,7 @@ newRepl = do
out <- newChan
repl' inp out
defaultImports
- defaultExtensions
+ defaultFlags
defaultBuildExpr
defaultProcessOutput
defaultPatience
@@ -297,6 +302,7 @@ defaultImports
,"import Data.Int"
,"import Data.Word"
,"import Data.List"
+ ,"import Data.List.Split"
,"import Data.Maybe"
,"import Data.Bits"
,"import Data.Array"
@@ -304,32 +310,44 @@ defaultImports
,"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_StandaloneDeriving
- ,Opt_MultiParamTypeClasses
- ,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
@@ -350,16 +368,20 @@ repl'
:: 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 <- mkSession
+ 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
@@ -388,7 +410,7 @@ repl' inp out imports exts build process wait len = do
{ hsc_IC = (hsc_IC session)
{ ic_tythings = filter (not . eqs) (ic_tythings (hsc_IC session)) }
}
- return "OK"
+ return "OK."
Type s -> errors $ formatType <$> exprType s
Kind s -> errors $ formatType . snd <$> typeKind True s
@@ -415,18 +437,18 @@ repl' inp out imports exts build process wait len = do
}
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
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)
+ -}

No commit comments for this range

Something went wrong with that request. Please try again.