diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 /= ".." diff --git a/ihaskell.cabal b/ihaskell.cabal --- a/ihaskell.cabal +++ b/ihaskell.cabal @@ -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 diff --git a/installation/ipython.sh b/installation/ipython.sh --- a/installation/ipython.sh +++ b/installation/ipython.sh @@ -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 diff --git a/installation/run.sh b/installation/run.sh --- a/installation/run.sh +++ b/installation/run.sh @@ -9,4 +9,5 @@ source $VIRTUALENV/bin/activate # Run IPython. -ipython $@ +# Quotes around $@ are necessary to deal properly with spaces. +ipython "$@" diff --git a/installation/virtualenv.sh b/installation/virtualenv.sh --- a/installation/virtualenv.sh +++ b/installation/virtualenv.sh @@ -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 diff --git a/profile/profile.tar b/profile/profile.tar Binary files a/profile/profile.tar and b/profile/profile.tar differ diff --git a/src/IHaskell/Eval/Completion.hs b/src/IHaskell/Eval/Completion.hs --- a/src/IHaskell/Eval/Completion.hs +++ b/src/IHaskell/Eval/Completion.hs @@ -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. diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -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 "$" "$" str) + fixDollarSigns = replace "$" "$" useDashV = "\nUse -v to see a list of the files searched for." isShowError err = startswith "No instance for (Show" err && diff --git a/src/IHaskell/Eval/Hoogle.hs b/src/IHaskell/Eval/Hoogle.hs --- a/src/IHaskell/Eval/Hoogle.hs +++ b/src/IHaskell/Eval/Hoogle.hs @@ -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 = diff --git a/src/IHaskell/Eval/Lint.hs b/src/IHaskell/Eval/Lint.hs --- a/src/IHaskell/Eval/Lint.hs +++ b/src/IHaskell/Eval/Lint.hs @@ -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 diff --git a/src/IHaskell/Eval/Parser.hs b/src/IHaskell/Eval/Parser.hs --- a/src/IHaskell/Eval/Parser.hs +++ b/src/IHaskell/Eval/Parser.hs @@ -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!" diff --git a/src/IHaskell/IPython.hs b/src/IHaskell/IPython.hs --- a/src/IHaskell/IPython.hs +++ b/src/IHaskell/IPython.hs @@ -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, diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs --- a/src/IHaskell/Types.hs +++ b/src/IHaskell/Types.hs @@ -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 { diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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)