ihaskell 0.3.0.2 → 0.3.0.3
raw patch · 14 files changed
+293/−175 lines, 14 filesbuild-type:Customsetup-changed
Files
- Setup.hs +22/−1
- ihaskell.cabal +3/−2
- installation/ipython.sh +4/−0
- installation/run.sh +2/−1
- installation/virtualenv.sh +1/−1
- profile/profile.tar binary
- src/IHaskell/Eval/Completion.hs +39/−22
- src/IHaskell/Eval/Evaluate.hs +99/−67
- src/IHaskell/Eval/Hoogle.hs +8/−0
- src/IHaskell/Eval/Lint.hs +36/−20
- src/IHaskell/Eval/Parser.hs +14/−10
- src/IHaskell/IPython.hs +2/−1
- src/IHaskell/Types.hs +16/−15
- src/Main.hs +47/−35
Setup.hs view
@@ -1,2 +1,23 @@ import Distribution.Simple-main = defaultMain++import Control.Applicative ((<$>))+import Data.List (isInfixOf)+import Codec.Archive.Tar (create)+import System.Directory (getDirectoryContents)++main = defaultMainWithHooks simpleUserHooks {+ preBuild = makeProfileTar+ }++makeProfileTar args flags = do+ putStrLn "Building profile.tar."++ let profileDir = "profile"+ tarFile = profileDir ++ "/profile.tar"+ files <- filter realFile <$> filter notProfileTar <$> getDirectoryContents profileDir+ print files+ create tarFile profileDir files+ preBuild simpleUserHooks args flags+ where+ notProfileTar str = not $ "profile.tar" `isInfixOf` str+ realFile str = str /= "." && str /= ".."
ihaskell.cabal view
@@ -7,7 +7,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.3.0.2+version: 0.3.0.3 -- A short (one-line) description of the package. synopsis: A Haskell backend kernel for the IPython project.@@ -37,7 +37,7 @@ category: Development -build-type: Simple+build-type: Custom -- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.16@@ -100,6 +100,7 @@ IHaskell.IPython IHaskell.Flags IHaskell.Types+ other-modules: Paths_ihaskell executable IHaskell
installation/ipython.sh view
@@ -10,6 +10,10 @@ # Activate the virtualenv. source $VIRTUALENV/bin/activate +# Upgrade pip.+echo "Upgrading pip."+pip install --upgrade "pip>=1.4.1"+ # Install all necessary dependencies with Pip. echo "Installing dependency (pyzmq)." pip install pyzmq==14.0.1
installation/run.sh view
@@ -9,4 +9,5 @@ source $VIRTUALENV/bin/activate # Run IPython.-ipython $@+# Quotes around $@ are necessary to deal properly with spaces.+ipython "$@"
installation/virtualenv.sh view
@@ -2,7 +2,7 @@ set -e # Which version of virtualenv to use.-VIRTUALENV=virtualenv-1.9+VIRTUALENV=virtualenv-1.9.1 # Where to install the virtualenv. DESTINATION=$1
profile/profile.tar view
binary file changed (96768 → 99840 bytes)
src/IHaskell/Eval/Completion.hs view
@@ -52,6 +52,7 @@ | HsFilePath String String | FilePath String String | KernelOption String+ | Extension String deriving (Show, Eq) complete :: String -> Int -> Interpreter (String, [String])@@ -95,25 +96,34 @@ return $ filter (prefix `isPrefixOf`) moduleNames DynFlag ext -> do+ -- Possibly leave out the fLangFlags? The+ -- -XUndecidableInstances vs. obsolete+ -- -fallow-undecidable-instances. let extName (name, _, _) = name- otherNames = ["-package","-Wall","-w"] ++- concatMap getSetName kernelOpts- fNames = map ("-f"++) (names ++ nonames)- where- -- possibly leave out the fLangFlags? The- -- -XUndecidableInstances vs. obsolete- -- -fallow-undecidable-instances- names = map extName fFlags ++ - map extName fWarningFlags ++ - map extName fLangFlags- nonames = map ("no"++) names - xNames = map ("-X"++) (names ++ nonames)- where- names = map extName xFlags- nonames = map ("No" ++) names- return $ filter (ext `isPrefixOf`) $ fNames ++ xNames ++ otherNames+ kernelOptNames = concatMap getSetName kernelOpts+ otherNames = ["-package","-Wall","-w"] + fNames = map extName fFlags ++ + map extName fWarningFlags ++ + map extName fLangFlags+ fNoNames = map ("no"++) fNames+ fAllNames = map ("-f"++) (fNames ++ fNoNames)++ xNames = map extName xFlags+ xNoNames = map ("No" ++) xNames+ xAllNames = map ("-X"++) (xNames ++ xNoNames)++ allNames = xAllNames ++ otherNames ++ fAllNames++ return $ filter (ext `isPrefixOf`) allNames++ Extension ext -> do+ let extName (name, _, _) = name+ xNames = map extName xFlags+ xNoNames = map ("No" ++) xNames+ return $ filter (ext `isPrefixOf`) $ xNames ++ xNoNames+ HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor FilePath lineUpToCursor match -> completePath lineUpToCursor@@ -149,17 +159,18 @@ completionType line loc target -- File and directory completions are special | startswith ":!" stripped- = case parseShell lineUpToCursor of - Right xs -> FilePath lineUpToCursor $ if endswith (last xs) lineUpToCursor then (last xs) else []- Left _ -> Empty+ = fileComplete FilePath | startswith ":l" stripped- = case parseShell lineUpToCursor of - Right xs -> HsFilePath lineUpToCursor $ if endswith (last xs) lineUpToCursor then (last xs) else []- Left _ -> Empty+ = fileComplete HsFilePath++ -- Complete :set, :opt, and :ext | startswith ":s" stripped = DynFlag candidate | startswith ":o" stripped = KernelOption candidate+ | startswith ":e" stripped+ = Extension candidate+ -- Use target for other completions. -- If it's empty, no completion. | null target@@ -178,6 +189,12 @@ isModName = all isCapitalized (init target) isCapitalized = isUpper . head lineUpToCursor = take loc line+ fileComplete filePath = case parseShell lineUpToCursor of + Right xs -> filePath lineUpToCursor $+ if endswith (last xs) lineUpToCursor+ then last xs+ else []+ Left _ -> Empty -- | Get the word under a given cursor location.
src/IHaskell/Eval/Evaluate.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances, PatternGuards #-}+{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances #-} {- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs a statement, declaration, import, or directive.@@ -72,7 +72,7 @@ import Paths_ihaskell (version) import Data.Version (versionBranch) -data ErrorOccurred = Success | Failure deriving (Show, Eq, Ord)+data ErrorOccurred = Success | Failure deriving (Show, Eq) debug :: Bool debug = False@@ -98,13 +98,10 @@ globalImports :: [String] globalImports =- [ "import IHaskell.Display"+ [ "import IHaskell.Display()" , "import qualified IPython.Stdin"- , "import Control.Applicative ((<$>))"- , "import GHC.IO.Handle (hDuplicateTo, hDuplicate, hClose)"- , "import System.Posix.IO"- , "import System.Posix.Files"- , "import System.IO"+ , "import qualified System.Posix.IO as IHaskellIO"+ , "import qualified System.IO as IHaskellSysIO" ] @@ -323,21 +320,27 @@ -- | Set dynamic flags. ----- adapted from GHC's InteractiveUI.hs (newDynFlags)-setDynFlags :: [String] -> Interpreter [ErrMsg]+-- This was adapted from GHC's InteractiveUI.hs (newDynFlags).+setDynFlags :: [String] -- ^ Flags to set.+ -> Interpreter [ErrMsg] -- ^ Errors from trying to set flags. setDynFlags ext = do+ -- Try to parse flags. flags <- getSessionDynFlags (flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)- let restorePkg x = x { packageFlags = packageFlags flags }+ -- First, try to check if this flag matches any extension name.- new_pkgs <- GHC.setProgramDynFlags (restorePkg flags')- GHC.setInteractiveDynFlags (restorePkg flags')- return $ map (("Could not parse: " ++) . unLoc) unrecognized ++- map ("Warning: " ++)- (map unLoc warnings ++- [ "-package not supported yet"- | packageFlags flags /= packageFlags flags' ])+ let restorePkg x = x { packageFlags = packageFlags flags }+ let restoredPkgs = flags' { packageFlags = packageFlags flags}+ GHC.setProgramDynFlags restoredPkgs+ GHC.setInteractiveDynFlags restoredPkgs + -- Create the parse errors.+ let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized+ allWarns = map unLoc warnings ++ + ["-package not supported yet" | packageFlags flags /= packageFlags flags']+ warnErrs = map ("Warning: " ++) allWarns+ return $ noParseErrs ++ warnErrs+ -- | Return the display data for this command, as well as whether it -- resulted in an error. evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut@@ -405,51 +408,80 @@ -- Since nothing prevents loading the module, compile and load it. Nothing -> doLoadModule modName modName -evalCommand a (Directive SetDynFlag flags) state- | let f o = case filter (elem o . getSetName) kernelOpts of- [] -> Right o- [z] | s:_ <- getOptionName z -> Left s- | otherwise -> error ("evalCommand Directive SetDynFlag impossible")- ds -> error ("kernelOpts has duplicate:"++ show (map getSetName ds)),- (optionFlags,oo) <- partitionEithers $ map f (words flags),- not (null optionFlags) = do- eo1 <- evalCommand a (Directive SetOption (unwords optionFlags)) state- eo2 <- evalCommand a (Directive SetDynFlag (unwords oo)) (evalState eo1)- return $ EvalOut {- evalStatus = max (evalStatus eo1) (evalStatus eo2),- evalResult = evalResult eo1 ++ evalResult eo2,- evalState = evalState eo2,- evalPager = evalPager eo1 ++ evalPager eo2+-- | Directives set via `:set`. +evalCommand output (Directive SetDynFlag flags) state = + case words flags of+ -- For a single flag.+ [flag] -> do+ write $ "DynFlags: " ++ flags++ -- Check if this is setting kernel options.+ case find (elem flag . getSetName) kernelOpts of+ -- If this is a kernel option, just set it.+ Just (KernelOpt _ _ updater) ->+ return EvalOut {+ evalStatus = Success,+ evalResult = mempty,+ evalState = updater state,+ evalPager = ""+ }++ -- If not a kernel option, must be a dyn flag.+ Nothing -> do+ errs <- setDynFlags [flag]+ let display = case errs of+ [] -> mempty+ _ -> displayError $ intercalate "\n" errs+ return EvalOut {+ evalStatus = Success,+ evalResult = display,+ evalState = state,+ evalPager = "" }- -evalCommand _ (Directive SetDynFlag flags) state = wrapExecution state $ do- write $ "DynFlag: " ++ flags- errs <- setDynFlags (words flags)- return $ case errs of- [] -> mempty- _ -> displayError $ intercalate "\n" errs -evalCommand a (Directive SetExtension opts) state = do+ -- Apply many flags.+ flag:manyFlags -> do+ firstEval <- evalCommand output (Directive SetDynFlag flags) state+ case evalStatus firstEval of+ Failure -> return firstEval+ Success -> do+ let newState = evalState firstEval+ results = evalResult firstEval+ restEval <- evalCommand output (Directive SetDynFlag $ unwords manyFlags) newState+ return restEval {+ evalResult = results ++ evalResult restEval+ }++evalCommand output (Directive SetExtension opts) state = do write $ "Extension: " ++ opts- evalCommand a (Directive SetDynFlag (concatMap (" -X"++) (words opts))) state+ let set = concatMap (" -X" ++) $ words opts+ evalCommand output (Directive SetDynFlag set) state evalCommand a (Directive SetOption opts) state = do write $ "Option: " ++ opts- let (lost, found) = partitionEithers- [ case filter (any (w==) . getOptionName) kernelOpts of- [x] -> Right (getUpdateKernelState x)- [] -> Left w- ds -> error ("kernelOpts has duplicate:" ++ show (map getOptionName ds))- | w <- words opts ]- warn- | null lost = mempty- | otherwise = displayError ("Could not recognize options: " ++ intercalate "," lost)- return EvalOut {- evalStatus = if null lost then Success else Failure,- evalResult = warn,- evalState = foldl' (flip ($)) state found,- evalPager = ""- }+ let (existing, nonExisting) = partition optionExists $ words opts+ if not $ null nonExisting+ then+ let err = "No such options: " ++ intercalate ", " nonExisting in+ return EvalOut {+ evalStatus = Failure,+ evalResult = displayError err,+ evalState = state,+ evalPager = ""+ }+ else+ let options = mapMaybe findOption $ words opts+ updater = foldl' (.) id $ map getUpdateKernelState options in+ return EvalOut {+ evalStatus = Success,+ evalResult = mempty,+ evalState = updater state,+ evalPager = ""+ }+ where+ optionExists = isJust . findOption+ findOption opt =+ find (elem opt . getOptionName) kernelOpts evalCommand _ (Directive GetType expr) state = wrapExecution state $ do write $ "Type: " ++ expr@@ -485,7 +517,7 @@ if exists then do setCurrentDirectory directory- return $ mempty+ return mempty else return $ displayError $ printf "No such directory: '%s'" directory cmd -> do@@ -740,7 +772,7 @@ Just bytestring -> case Serialize.decode bytestring of Left err -> error err- Right display -> do+ Right display -> return $ if useSvg state then display@@ -919,19 +951,19 @@ -- Statements run before the thing we're evaluating. initStmts = [ printf "let %s = it" itVariable- , printf "(%s, %s) <- createPipe" readVariable writeVariable- , printf "%s <- dup stdOutput" oldVariable- , voidpf "dupTo %s stdOutput" writeVariable- , voidpf "hSetBuffering stdout NoBuffering"+ , printf "(%s, %s) <- IHaskellIO.createPipe" readVariable writeVariable+ , printf "%s <- IHaskellIO.dup IHaskellIO.stdOutput" oldVariable+ , voidpf "IHaskellIO.dupTo %s IHaskellIO.stdOutput" writeVariable+ , voidpf "IHaskellSysIO.hSetBuffering IHaskellSysIO.stdout IHaskellSysIO.NoBuffering" , printf "let it = %s" itVariable ] -- Statements run after evaluation. postStmts = [ printf "let %s = it" itVariable- , voidpf "hFlush stdout"- , voidpf "dupTo %s stdOutput" oldVariable- , voidpf "closeFd %s" writeVariable+ , voidpf "IHaskellSysIO.hFlush IHaskellSysIO.stdout"+ , voidpf "IHaskellIO.dupTo %s IHaskellIO.stdOutput" oldVariable+ , voidpf "IHaskellIO.closeFd %s" writeVariable , printf "let it = %s" itVariable ] pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable@@ -1049,7 +1081,7 @@ rstrip . typeCleaner where- fixDollarSigns str = traceShowId (replace "$" "<span>$</span>" str)+ fixDollarSigns = replace "$" "<span>$</span>" useDashV = "\nUse -v to see a list of the files searched for." isShowError err = startswith "No instance for (Show" err &&
src/IHaskell/Eval/Hoogle.hs view
@@ -150,6 +150,12 @@ span "hoogle-module" (link loc $ extractModule string) ++ packageSub package + | startswith "class" string+ = let package = extractPackageName loc in+ cls ++ " " +++ span "hoogle-class" (link loc $ extractClass string) +++ packageSub package+ | otherwise = let [name, args] = split "::" string package = extractPackageName loc@@ -163,8 +169,10 @@ where extractPackage = strip . replace "package" "" extractModule = strip . replace "module" ""+ extractClass = strip . replace "class" "" pkg = span "hoogle-head" "package" mod = span "hoogle-head" "module"+ cls = span "hoogle-head" "class" unicodeReplace :: String -> String unicodeReplace =
src/IHaskell/Eval/Lint.hs view
@@ -48,11 +48,12 @@ writeFile (fromString filename) fileContents suggestions <- catMaybes <$> map parseSuggestion <$> hlint [filename, "--quiet"]- return $+ return $ Display $ if null suggestions- then Display []- else Display- [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]+ then []+ else + [plain $ concatMap plainSuggestion suggestions,+ html $ htmlSuggestions suggestions] where -- Join together multiple valid file blocks into a single file. -- However, join them with padding so that the line numbers are@@ -117,6 +118,7 @@ parseSuggestion suggestion = do let str = showSuggestion (show suggestion) severity = suggestionSeverity suggestion+ guard (severity /= HLint.Ignore) let lintSeverity = case severity of Warning -> LintWarning@@ -147,24 +149,38 @@ showSuggestion :: String -> String showSuggestion = - replace ("return " ++ lintIdent) "" .- replace (lintIdent ++ "=") "" .- dropDo- where+ remove ("return " ++ lintIdent) .+ remove (lintIdent ++ "=") .+ dropDo+ where+ remove str = replace str "" - -- drop leading ' do ', and blank spaces following+ -- Drop leading ' do ', and blank spaces following. dropDo :: String -> String- dropDo = unlines . f . lines- where- f :: [String] -> [String]- f ((stripPrefix " do " -> Just a) : as) =- let as' = catMaybes- $ takeWhile isJust- $ map (stripPrefix " ") as- in a : as' ++ f (drop (length as') as)- f (x:xs) = x : f xs- f [] = []+ dropDo string = + -- If this is not a statement, we don't need to drop the do statement.+ if ("return " ++ lintIdent) `isInfixOf` string+ then unlines . clean . lines $ string+ else string + clean :: [String] -> [String]+ -- If the first line starts with a `do`...+ -- Note that hlint always indents by two spaces in its output.+ clean ((stripPrefix " do " -> Just a) : as) =+ -- Take all indented lines and unindent them.+ let unindented = catMaybes+ $ takeWhile isJust+ $ map (stripPrefix " ") as+ fullDo = a:unindented+ afterDo = drop (length unindented) as+ in + -- + fullDo ++ clean afterDo++ -- Ignore other list elements - just proceed onwards.+ clean (x:xs) = x : clean xs+ clean [] = []+ -- | Convert a code chunk into something that could go into a file. -- The line number on the output is the same as on the input. makeValid :: Located CodeBlock -> Located String@@ -193,7 +209,7 @@ $ filter (not . all isSpace) (lines (expandTabs stmt)) finalReturn = replicate nLeading ' ' ++ "return " ++ lintIdent- in intercalate ("\n ") ((lintIdent ++ " $ do") : lines stmt ++ [finalReturn])+ in intercalate "\n " ((lintIdent ++ " $ do") : lines stmt ++ [finalReturn]) -- Modules, declarations, and type signatures are fine as is. Module mod -> mod
src/IHaskell/Eval/Parser.hs view
@@ -125,6 +125,10 @@ activateParsingExtensions :: GhcMonad m => CodeBlock -> m () activateParsingExtensions (Directive SetExtension ext) = void $ setExtension ext+activateParsingExtensions (Directive SetDynFlag flags) = + case stripPrefix "-X" flags of+ Just ext -> void $ setExtension ext+ Nothing -> return () activateParsingExtensions _ = return () -- | Parse a single chunk of code, as indicated by the layout of the code.@@ -251,16 +255,16 @@ [] -> False dir:_ -> dir `elem` tail (inits dirname) directives =- [(GetType, "type")- ,(GetInfo, "info")- ,(SearchHoogle, "hoogle")- ,(GetDoc, "documentation")- ,(SetDynFlag, "set")- ,(LoadFile, "load")- ,(SetOption, "option")- ,(SetExtension, "extension")- ,(GetHelp, "?")- ,(GetHelp, "help")+ [ (GetType, "type")+ , (GetInfo, "info")+ , (SearchHoogle, "hoogle")+ , (GetDoc, "documentation")+ , (SetDynFlag, "set")+ , (LoadFile, "load")+ , (SetOption, "option")+ , (SetExtension, "extension")+ , (GetHelp, "?")+ , (GetHelp, "help") ] parseDirective _ _ = error "Directive must start with colon!"
src/IHaskell/IPython.hs view
@@ -40,7 +40,7 @@ -- | Which commit of IPython we are on. ipythonCommit :: Text-ipythonCommit = "12247a8f4feffe16fb0bbdc0a18e7a1f46cd2ba1"+ipythonCommit = "8858f7eecc31f363ec8b391ac0d9698f99d556a5" -- | The IPython profile name. ipythonProfile :: String@@ -117,6 +117,7 @@ nbconvert which fmt name = void . shellyNoDir $ do curdir <- pwd nbdir <- notebookDir+ -- Find which of the options is available. let notebookOptions = [ curdir </> fpFromString name,
src/IHaskell/Types.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, PatternGuards #-}-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-} -- | Description : All message type definitions. module IHaskell.Types ( Message (..),@@ -105,22 +104,24 @@ | IPythonNotebook deriving (Show, Eq, Read) --- | names the ways to update the IHaskell 'KernelState' by `:set`--- ('getSetName') and `:option` ('getOptionName') directives-data KernelOpt = KernelOpt- { getOptionName, getSetName :: [String],- getUpdateKernelState :: KernelState -> KernelState }+-- | Kernel options to be set via `:set` and `:option`.+data KernelOpt = KernelOpt {+ getOptionName :: [String], -- ^ Ways to set this option via `:option`+ getSetName :: [String], -- ^ Ways to set this option via `:set`+ getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel state.+ } kernelOpts :: [KernelOpt] kernelOpts =- [KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn },- KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff },- KernelOpt ["svg"] [] $ \state -> state { useSvg = True },- KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False },- KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True },- KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False },- KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True },- KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }]+ [ KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn }+ , KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff }+ , KernelOpt ["svg"] [] $ \state -> state { useSvg = True }+ , KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False }+ , KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True }+ , KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False }+ , KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True }+ , KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }+ ] -- | Initialization information for the kernel. data InitInfo = InitInfo {
src/Main.hs view
@@ -2,29 +2,36 @@ -- | Description : Argument parsing and basic messaging loop, using Haskell -- Chans to communicate with the ZeroMQ sockets. module Main where-import ClassyPrelude hiding (liftIO)-import Prelude (last, read)-import Control.Concurrent.Chan-import Control.Concurrent (threadDelay)-import Data.Aeson-import Text.Printf-import System.Exit (exitSuccess)-import System.Directory -import qualified Data.Map as Map+-- Prelude imports.+import ClassyPrelude hiding (liftIO)+import Prelude (last, read) -import IHaskell.Types-import IPython.ZeroMQ-import qualified IPython.Message.UUID as UUID-import IHaskell.Eval.Evaluate-import IHaskell.Eval.Completion (complete)-import IHaskell.Eval.Info-import qualified Data.ByteString.Char8 as Chars-import IHaskell.IPython-import qualified IPython.Stdin as Stdin-import IHaskell.Flags+-- Standard library imports.+import Control.Concurrent (threadDelay)+import Control.Concurrent.Chan+import Data.Aeson+import Data.String.Utils (strip)+import System.Directory+import System.Exit (exitSuccess)+import Text.Printf+import System.Posix.Signals+import qualified Data.Map as Map -import GHC hiding (extensions, language)+-- IHaskell imports.+import IHaskell.Eval.Completion (complete)+import IHaskell.Eval.Evaluate+import IHaskell.Eval.Info+import IHaskell.Flags+import IHaskell.IPython+import IHaskell.Types+import IPython.ZeroMQ+import qualified Data.ByteString.Char8 as Chars+import qualified IPython.Message.UUID as UUID+import qualified IPython.Stdin as Stdin++-- GHC API imports.+import GHC hiding (extensions, language) import Outputable (showSDoc, ppr) -- | Compute the GHC API version number using the dist/build/autogen/cabal_macros.h@@ -143,6 +150,11 @@ -- Receive and reply to all messages on the shell socket. interpret True $ do+ -- Ignore Ctrl-C the first time. This has to go inside the+ -- `interpret`, because GHC API resets the signal handlers for some+ -- reason (completely unknown to me).+ liftIO ignoreCtrlC+ -- Initialize the context by evaluating everything we got from the -- command line flags. This includes enabling some extensions and also -- running some code.@@ -171,6 +183,9 @@ -- Write the reply to the reply channel. liftIO $ writeChan (shellReplyChannel interface) reply+ where+ ignoreCtrlC =+ installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.") Nothing -- Initial kernel state. initialKernelState :: IO (MVar KernelState)@@ -304,23 +319,20 @@ replyTo _ req@CompleteRequest{} replyHeader state = do- (matchedText, completions) <- complete (Chars.unpack $ getCodeLine req) (getCursorPos req)+ (matchedText, completions) <- complete (Chars.unpack $ getCodeLine req) (getCursorPos req) - let reply = CompleteReply replyHeader (map Chars.pack completions) (Chars.pack matchedText) (getCodeLine req) True- return (state, reply)+ let reply = CompleteReply replyHeader (map Chars.pack completions) (Chars.pack matchedText) (getCodeLine req) True+ return (state, reply) -- | Reply to the object_info_request message. Given an object name, return -- | the associated type calculated by GHC. replyTo _ ObjectInfoRequest{objectName=oname} replyHeader state = do- docs <- info $ Chars.unpack oname- let reply = ObjectInfoReply {- header = replyHeader,- objectName = oname, - objectFound = docs == "",- objectTypeString = Chars.pack docs,- objectDocString = Chars.pack docs - }- return (state, reply)--- + docs <- info $ Chars.unpack oname+ let reply = ObjectInfoReply {+ header = replyHeader,+ objectName = oname, + objectFound = strip docs /= "",+ objectTypeString = Chars.pack docs,+ objectDocString = Chars.pack docs + }+ return (state, reply)