diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -5,6 +5,8 @@ import Codec.Archive.Tar (create) import System.Directory (getDirectoryContents) +-- This is currently *not used*. build-type is Simple. +-- This is because it breaks installing from Hackage. main = defaultMainWithHooks simpleUserHooks { preBuild = makeProfileTar } 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.3 +version: 0.3.0.4 -- 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: Custom +build-type: Simple -- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.16 @@ -64,7 +64,8 @@ directory -any, filepath -any, ghc ==7.6.*, - ghc-parser -any, + ghc-parser >=0.1.1, + ghci-lib >=0.1, ghc-paths ==0.1.*, haskeline -any, here -any, @@ -141,7 +142,8 @@ directory -any, filepath -any, ghc ==7.6.*, - ghc-parser -any, + ghc-parser >=0.1.1, + ghci-lib >=0.1, ghc-paths ==0.1.*, haskeline -any, here -any, @@ -183,7 +185,8 @@ directory -any, filepath -any, ghc ==7.6.*, - ghc-parser -any, + ghc-parser >=0.1.1, + ghci-lib >=0.1, ghc-paths ==0.1.*, haskeline -any, here -any, diff --git a/installation/ipython.sh b/installation/ipython.sh --- a/installation/ipython.sh +++ b/installation/ipython.sh @@ -32,4 +32,4 @@ # Install IPython itself. echo "Installing IPython (this may take a while)." -pip install -e git+https://github.com/ipython/ipython.git@$COMMIT#egg=ipython-dev +pip install -e git+https://github.com/gibiansky/ipython.git@$COMMIT#egg=ipython-dev diff --git a/installation/update.sh b/installation/update.sh --- a/installation/update.sh +++ b/installation/update.sh @@ -16,5 +16,5 @@ # Update IPython. echo "Updating IPython (this may take a while)." - pip install --upgrade -e git+https://github.com/ipython/ipython.git@$COMMIT#egg=ipython-dev + pip install --upgrade -e git+https://github.com/gibiansky/ipython.git@$COMMIT#egg=ipython-dev fi; 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/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -72,6 +72,9 @@ import Paths_ihaskell (version) import Data.Version (versionBranch) +import Language.Haskell.GHC.Interpret +import Language.Haskell.GHC.Util + data ErrorOccurred = Success | Failure deriving (Show, Eq) debug :: Bool @@ -104,18 +107,15 @@ , "import qualified System.IO as IHaskellSysIO" ] - - -- | Run an interpreting action. This is effectively runGhc with -- initialization and importing. First argument indicates whether `stdin` -- is handled specially, which cannot be done in a testing environment. interpret :: Bool -> Interpreter a -> IO a interpret allowedStdin action = runGhc (Just libdir) $ do - -- Set the dynamic session flags - originalFlags <- getSessionDynFlags - let dflags = xopt_set originalFlags Opt_ExtendedDefaultRules + initGhci -- If we're in a sandbox, add the relevant package database + dflags <- getSessionDynFlags sandboxPackages <- liftIO getSandboxPackageConf let pkgConfs = case sandboxPackages of Nothing -> extraPkgConfs dflags @@ -123,10 +123,7 @@ let pkg = PkgConfFile path in (pkg:) . extraPkgConfs dflags - void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted, - ghcLink = LinkInMemory, - pprCols = 300, - extraPkgConfs = pkgConfs } + void $ setSessionDynFlags $ dflags { extraPkgConfs = pkgConfs } initializeImports @@ -291,20 +288,6 @@ evalPager = "" } -doc :: GhcMonad m => SDoc -> m String -doc sdoc = do - flags <- getSessionDynFlags - unqual <- getPrintUnqual - let style = mkUserStyle unqual AllTheWay - let cols = pprCols flags - d = runSDoc sdoc (initSDocContext flags style) - return $ Pretty.fullRender Pretty.PageMode cols 1.5 string_txt "" d - where - string_txt :: Pretty.TextDetails -> String -> String - string_txt (Pretty.Chr c) s = c:s - string_txt (Pretty.Str s1) s2 = s1 ++ s2 - string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2 - string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2 wrapExecution :: KernelState @@ -318,50 +301,19 @@ evalPager = "" } --- | Set dynamic flags. --- --- 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) - -- First, try to check if this flag matches any extension name. - 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 evalCommand _ (Import importStr) state = wrapExecution state $ do write $ "Import: " ++ importStr - importDecl <- parseImportDecl importStr - context <- getContext - - -- If we've imported this implicitly, remove the old import. - let noImplicit = filter (not . implicitImportOf importDecl) context - setContext $ IIDecl importDecl : noImplicit + evalImport importStr - flags <- getSessionDynFlags + -- Warn about `it` variable. return $ if "Test.Hspec" `isInfixOf` importStr then displayError $ "Warning: Hspec is unusable in IHaskell until the resolution of GHC bug #8639." ++ "\nThe variable `it` is shadowed and cannot be accessed, even in qualified form." else mempty - where - implicitImportOf :: ImportDecl RdrName -> InteractiveImport -> Bool - implicitImportOf _ (IIModule _) = False - implicitImportOf imp (IIDecl decl) = ideclImplicit decl && ((==) `on` (unLoc . ideclName)) decl imp evalCommand _ (Module contents) state = wrapExecution state $ do write $ "Module:\n" ++ contents @@ -428,7 +380,7 @@ -- If not a kernel option, must be a dyn flag. Nothing -> do - errs <- setDynFlags [flag] + errs <- setFlags [flag] let display = case errs of [] -> mempty _ -> displayError $ intercalate "\n" errs @@ -441,7 +393,7 @@ -- Apply many flags. flag:manyFlags -> do - firstEval <- evalCommand output (Directive SetDynFlag flags) state + firstEval <- evalCommand output (Directive SetDynFlag flag) state case evalStatus firstEval of Failure -> return firstEval Success -> do @@ -485,10 +437,7 @@ evalCommand _ (Directive GetType expr) state = wrapExecution state $ do write $ "Type: " ++ expr - result <- exprType expr - flags <- getSessionDynFlags - let typeStr = showSDocUnqual flags $ ppr result - return $ formatType typeStr + formatType <$> getType expr evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do write $ "Load: " ++ name @@ -812,11 +761,8 @@ evalCommand _ (Declaration decl) state = wrapExecution state $ do write $ "Declaration:\n" ++ decl - names <- runDecls decl - - dflags <- getSessionDynFlags - let boundNames = map (replace ":Interactive." "" . showPpr dflags) names - nonDataNames = filter (not . isUpper . head) boundNames + boundNames <- evalDeclarations decl + let nonDataNames = filter (not . isUpper . head) boundNames -- Display the types of all bound names if the option is on. -- This is similar to GHCi :set +t. @@ -824,6 +770,7 @@ then return mempty else do -- Get all the type strings. + dflags <- getSessionDynFlags types <- forM nonDataNames $ \name -> do theType <- showSDocUnqual dflags . ppr <$> exprType name return $ name ++ " :: " ++ theType 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 @@ -17,7 +17,7 @@ import IHaskell.Types import IHaskell.Display import IHaskell.IPython -import IHaskell.Eval.Parser +import IHaskell.Eval.Parser hiding (line) data LintSeverity = LintWarning | LintError deriving (Eq, Show) 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 @@ -50,11 +50,6 @@ | ParseError StringLoc ErrMsg -- ^ An error indicating that parsing the code block failed. deriving (Show, Eq) --- | Store locations along with a value. -data Located a = Located LineNumber a deriving (Eq, Show) -instance Functor Located where - fmap f (Located line a) = Located line $ f a - -- | Directive types. Each directive is associated with a string in the -- directive code block. data DirectiveType @@ -70,14 +65,6 @@ | GetDoc -- ^ Get documentation for an identifier via Hoogle. deriving (Show, Eq) --- | Unlocate something - drop the position. -unloc :: Located a -> a -unloc (Located _ a) = a - --- | Get the line number of a located element. -line :: Located a -> LineNumber -line (Located l _) = l - -- | Parse a string into code blocks. parseString :: GhcMonad m => String -> m [Located CodeBlock] parseString codeString = do @@ -88,7 +75,7 @@ Parsed {} -> return [Located 1 $ Module codeString] Failure {} -> do -- Split input into chunks based on indentation. - let chunks = layoutChunks $ dropComments codeString + let chunks = layoutChunks $ removeComments codeString result <- joinFunctions <$> processChunks [] chunks -- Return to previous flags. When parsing, flags can be set to make @@ -268,69 +255,6 @@ ] parseDirective _ _ = error "Directive must start with colon!" - --- | Split an input string into chunks based on indentation. --- A chunk is a line and all lines immediately following that are indented --- beyond the indentation of the first line. This parses Haskell layout --- rules properly, and allows using multiline expressions via indentation. -layoutChunks :: String -> [Located String] -layoutChunks = go 1 - where - go :: LineNumber -> String -> [Located String] - go line = filter (not . null . unloc) . map (fmap strip) . layoutLines line . lines - - layoutLines :: LineNumber -> [String] -> [Located String] - -- Empty string case. If there's no input, output is empty. - layoutLines _ [] = [] - - -- Use the indent of the first line to find the end of the first block. - layoutLines lineIdx all@(firstLine:rest) = - let firstIndent = indentLevel firstLine - blockEnded line = indentLevel line <= firstIndent in - case findIndex blockEnded rest of - -- If the first block doesn't end, return the whole string, since - -- that just means the block takes up the entire string. - Nothing -> [Located lineIdx $ intercalate "\n" all] - - -- We found the end of the block. Split this bit out and recurse. - Just idx -> - let (before, after) = splitAt idx rest in - Located lineIdx (joinLines $ firstLine:before) : go (lineIdx + idx + 1) (joinLines after) - - -- Compute indent level of a string as number of leading spaces. - indentLevel :: String -> Int - indentLevel (' ':str) = 1 + indentLevel str - - -- Count a tab as two spaces. - indentLevel ('\t':str) = 2 + indentLevel str - - -- Count empty lines as a large indent level, so they're always with the previous expression. - indentLevel "" = 100000 - - indentLevel _ = 0 - --- Not the same as 'unlines', due to trailing \n -joinLines :: [String] -> String -joinLines = intercalate "\n" - --- | Drop comments from Haskell source. -dropComments :: String -> String -dropComments = removeOneLineComments . removeMultilineComments - where - -- Don't remove comments after cmd directives - removeOneLineComments (':':'!':remaining) = ":!" ++ takeWhile (/= '\n') remaining ++ - removeOneLineComments (dropWhile (/= '\n') remaining) - removeOneLineComments ('-':'-':remaining) = removeOneLineComments (dropWhile (/= '\n') remaining) - removeOneLineComments (x:xs) = x:removeOneLineComments xs - removeOneLineComments x = x - - removeMultilineComments ('{':'-':remaining) = - case subIndex "-}" remaining of - Nothing -> "" - Just idx -> removeMultilineComments $ drop (2 + idx) remaining - removeMultilineComments (x:xs) = x:removeMultilineComments xs - removeMultilineComments x = x - -- | Parse a module and return the name declared in the 'module X where' -- line. That line is required, and if it does not exist, this will error. -- Names with periods in them are returned piece y piece. @@ -344,3 +268,7 @@ case unLoc <$> hsmodName (unLoc mod) of Nothing -> error "Module must have a name." Just name -> return $ split "." $ moduleNameString name + +-- Not the same as 'unlines', due to trailing \n +joinLines :: [String] -> String +joinLines = intercalate "\n" 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 = "8858f7eecc31f363ec8b391ac0d9698f99d556a5" +ipythonCommit = "4a08574f74201ef7ca39a4e80d19a2d158ab6950" -- | The IPython profile name. ipythonProfile :: String diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -301,8 +301,11 @@ unless (null pager) $ modifyMVar_ pagerOutput (return . (++ pager ++ "\n")) - -- Run code and publish to the frontend as we go. let execCount = getExecutionCounter state + -- Let all frontends know the execution count and code that's about to run + inputHeader <- liftIO $ dupHeader replyHeader InputMessage + send $ PublishInput inputHeader (Chars.unpack code) execCount + -- Run code and publish to the frontend as we go. updatedState <- evaluate state (Chars.unpack code) publish -- Notify the frontend that we're done computing.