diff --git a/Hspec.hs b/Hspec.hs deleted file mode 100644 --- a/Hspec.hs +++ /dev/null @@ -1,382 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -import GHC -import GHC.Paths -import Data.IORef -import Control.Monad -import Data.List -import System.Directory -import Data.String.Here -import Data.String.Utils (strip, replace) - -import IHaskell.Eval.Parser -import IHaskell.Types -import IHaskell.IPython -import IHaskell.Eval.Evaluate as Eval -import IHaskell.Eval.Completion - -import Test.Hspec -import Test.Hspec.HUnit - -doGhc = runGhc (Just libdir) - -parses = doGhc . parseString - -like parser desired = parser >>= (`shouldBe` desired) - -is string blockType = do - result <- doGhc $ parseString string - result `shouldBe` [blockType $ strip string] - -eval string = do - outputAccum <- newIORef [] - let publish _ displayDatas = modifyIORef outputAccum (displayDatas :) - getTemporaryDirectory >>= setCurrentDirectory - interpret $ Eval.evaluate 1 string publish - out <- readIORef outputAccum - return $ reverse out - -becomes string expected = do - let indent (' ':x) = 1 + indent x - indent _ = 0 - empty = null . strip - stringLines = filter (not . empty) $ lines string - minIndent = minimum (map indent stringLines) - newString = unlines $ map (drop minIndent) stringLines - eval newString >>= comparison - where - comparison results = do - when (length results /= length expected) $ - expectationFailure $ "Expected result to have " ++ show (length expected) - ++ " results. Got " ++ show results - - let isPlain (Display PlainText _) = True - isPlain _ = False - - forM_ (zip results expected) $ \(result, expected) -> - case find isPlain result of - Just (Display PlainText str) -> str `shouldBe` expected - Nothing -> expectationFailure $ "No plain-text output in " ++ show result - -completes string expected = completionTarget newString cursorloc `shouldBe` expected - where (newString, cursorloc) = case elemIndex '!' string of - Nothing -> error "Expected cursor written as '!'." - Just idx -> (replace "!" "" string, idx) - -completionHas string expected = do - (matched, completions) <- doGhc $ do - initCompleter - complete newString cursorloc - let existsInCompletion = (`elem` completions) - unmatched = filter (not . existsInCompletion) expected - unmatched `shouldBe` [] - where (newString, cursorloc) = case elemIndex '!' string of - Nothing -> error "Expected cursor written as '!'." - Just idx -> (replace "!" "" string, idx) - -initCompleter :: GhcMonad m => m () -initCompleter = do - flags <- getSessionDynFlags - setSessionDynFlags $ flags { hscTarget = HscInterpreted, ghcLink = LinkInMemory } - - -- Import modules. - imports <- mapM parseImportDecl ["import Prelude", - "import qualified Control.Monad", - "import qualified Data.List as List", - "import Data.Maybe as Maybe"] - setContext $ map IIDecl imports - -main :: IO () -main = hspec $ do - parserTests - ipythonTests - evalTests - completionTests - -completionTests = do - describe "Completion" $ do - it "correctly gets the completion identifier without dots" $ do - "hello!" `completes` ["hello"] - "hello aa!bb goodbye" `completes` ["aa"] - "hello aabb! goodbye" `completes` ["aabb"] - "aacc! goodbye" `completes` ["aacc"] - "hello !aabb goodbye" `completes` [] - "!aabb goodbye" `completes` [] - - it "correctly gets the completion identifier with dots" $ do - "hello test.aa!bb goodbye" `completes` ["test", "aa"] - "Test.!" `completes` ["Test", ""] - "Test.Thing!" `completes` ["Test", "Thing"] - "Test.Thing.!" `completes` ["Test", "Thing", ""] - "Test.Thing.!nope" `completes` ["Test", "Thing", ""] - - it "correctly gets the completion type" $ do - completionType "import Data." ["Data", ""] `shouldBe` ModuleName "Data" "" - completionType "import Prel" ["Prel"] `shouldBe` ModuleName "" "Prel" - completionType "import D.B.M" ["D", "B", "M"] `shouldBe` ModuleName "D.B" "M" - completionType " import A." ["A", ""] `shouldBe` ModuleName "A" "" - completionType "import a.x" ["a", "x"] `shouldBe` Identifier "x" - completionType "A.x" ["A", "x"] `shouldBe` Qualified "A" "x" - completionType "a.x" ["a", "x"] `shouldBe` Identifier "x" - completionType "pri" ["pri"] `shouldBe` Identifier "pri" - - it "properly completes identifiers" $ do - "pri!" `completionHas` ["print"] - "ma!" `completionHas` ["map"] - "hello ma!" `completionHas` ["map"] - "print $ catMa!" `completionHas` ["catMaybes"] - - it "properly completes qualified identifiers" $ do - "Control.Monad.liftM!" `completionHas` [ "Control.Monad.liftM" - , "Control.Monad.liftM2" - , "Control.Monad.liftM5"] - "print $ List.intercal!" `completionHas` ["List.intercalate"] - "print $ Data.Maybe.cat!" `completionHas` ["Data.Maybe.catMaybes"] - "print $ Maybe.catM!" `completionHas` ["Maybe.catMaybes"] - - it "properly completes imports" $ do - "import Data.!" `completionHas` ["Data.Maybe", "Data.List"] - "import Data.M!" `completionHas` ["Data.Maybe"] - "import Prel!" `completionHas` ["Prelude"] - -evalTests = do - describe "Code Evaluation" $ do - it "evaluates expressions" $ do - "3" `becomes` ["3"] - "3+5" `becomes` ["8"] - "print 3" `becomes` ["3"] - [hereLit| - let x = 11 - z = 10 in - x+z - |] `becomes` ["21"] - - it "evaluates multiline expressions" $ do - [hereLit| - import Control.Monad - forM_ [1, 2, 3] $ \x -> - print x - |] `becomes` ["1\n2\n3"] - - it "evaluates function declarations silently" $ do - [hereLit| - fun :: [Int] -> Int - fun [] = 3 - fun (x:xs) = 10 - fun [1, 2] - |] `becomes` ["10"] - - it "evaluates data declarations" $ do - [hereLit| - data X = Y Int - | Z String - deriving (Show, Eq) - print [Y 3, Z "No"] - print (Y 3 == Z "No") - |] `becomes` ["[Y 3,Z \"No\"]", "False"] - - it "evaluates do blocks in expressions" $ do - [hereLit| - show (show (do - Just 10 - Nothing - Just 100)) - |] `becomes` ["\"\\\"Nothing\\\"\""] - - it "is silent for imports" $ do - "import Control.Monad" `becomes` [] - "import qualified Control.Monad" `becomes` [] - "import qualified Control.Monad as CM" `becomes` [] - "import Control.Monad (when)" `becomes` [] - - it "evaluates directives" $ do - ":typ 3" `becomes` ["forall a. Num a => a"] - ":in String" `becomes` ["type String = [Char] \t-- Defined in `GHC.Base'"] - -ipythonTests = do - describe "Parse IPython Version" $ do - it "parses 2.0.0-dev" $ - parseVersion "2.0.0-dev" `shouldBe` [2, 0, 0] - it "parses 2.0.0-alpha" $ - parseVersion "2.0.0-dev" `shouldBe` [2, 0, 0] - it "parses 12.5.10" $ - parseVersion "12.5.10" `shouldBe` [12, 5, 10] - -parserTests = do - layoutChunkerTests - moduleNameTests - parseStringTests - -layoutChunkerTests = describe "Layout Chunk" $ do - it "chunks 'a string'" $ - layoutChunks "a string" `shouldBe` ["a string"] - - it "chunks 'a\\nstring'" $ - layoutChunks "a\n string" `shouldBe` ["a\n string"] - - it "chunks 'a\\n string\\nextra'" $ - layoutChunks "a\n string\nextra" `shouldBe` ["a\n string","extra"] - - it "chunks strings with too many lines" $ - layoutChunks "a\n\nstring" `shouldBe` ["a","string"] - -moduleNameTests = describe "Get Module Name" $ do - it "parses simple module names" $ - "module A where\nx = 3" `named` ["A"] - it "parses module names with dots" $ - "module A.B where\nx = 3" `named` ["A", "B"] - it "parses module names with exports" $ - "module A.B.C ( x ) where x = 3" `named` ["A", "B", "C"] - it "errors when given unnamed modules" $ do - doGhc (getModuleName "x = 3") `shouldThrow` anyException - where - named str result = do - res <- doGhc $ getModuleName str - res `shouldBe` result - -parseStringTests = describe "Parser" $ do - it "parses empty strings" $ - parses "" `like` [] - - it "parses simple imports" $ - "import Data.Monoid" `is` Import - - it "parses simple arithmetic" $ - "3 + 5" `is` Expression - - it "parses :type" $ - parses ":type x\n:ty x" `like` [ - Directive GetType "x", - Directive GetType "x" - ] - - it "parses :info" $ - parses ":info x\n:in x" `like` [ - Directive GetInfo "x", - Directive GetInfo "x" - ] - - it "parses :help and :?" $ - parses ":? x\n:help x" `like` [ - Directive GetHelp "x", - Directive GetHelp "x" - ] - - it "parses :set x" $ - parses ":set x" `like` [ - Directive HelpForSet "x" - ] - - it "parses :extension x" $ - parses ":ex x\n:extension x" `like` [ - Directive SetExtension "x", - Directive SetExtension "x" - ] - - it "fails to parse :nope" $ - parses ":nope goodbye" `like` [ - ParseError (Loc 1 1) "Unknown directive: 'nope'." - ] - - it "parses number followed by let stmt" $ - parses "3\nlet x = expr" `like` [ - Expression "3", - Statement "let x = expr" - ] - - it "parses let x in y" $ - "let x = 3 in x + 3" `is` Expression - - it "parses a data declaration" $ - "data X = Y Int" `is` Declaration - - it "parses number followed by type directive" $ - parses "3\n:t expr" `like` [ - Expression "3", - Directive GetType "expr" - ] - - it "parses a <- statement" $ - "y <- print 'no'" `is` Statement - - it "parses a <- stmt followed by let stmt" $ - parses "y <- do print 'no'\nlet x = expr" `like` [ - Statement "y <- do print 'no'", - Statement "let x = expr" - ] - - it "parses <- followed by let followed by expr" $ - parses "y <- do print 'no'\nlet x = expr\nexpression" `like` [ - Statement "y <- do print 'no'", - Statement "let x = expr", - Expression "expression" - ] - - it "parses two print statements" $ - parses "print yes\nprint no" `like` [ - Expression "print yes", - Expression "print no" - ] - - it "parses a pattern-maching function declaration" $ - "fun [] = 10" `is` Declaration - - it "parses a function decl followed by an expression" $ - parses "fun [] = 10\nprint 'h'" `like` [ - Declaration "fun [] = 10", - Expression "print 'h'" - ] - - it "parses list pattern matching fun decl" $ - "fun (x : xs) = 100" `is` Declaration - - it "parses two pattern matches as the same declaration" $ - "fun [] = 10\nfun (x : xs) = 100" `is` Declaration - - it "parses a type signature followed by a declaration" $ - "fun :: [a] -> Int\nfun [] = 10\nfun (x : xs) = 100" `is` Declaration - - it "parases a simple module" $ - "module A where x = 3" `is` Module - - it "parses a module with an export" $ - "module B (x) where x = 3" `is` Module - - it "breaks when a let is incomplete" $ - parses "let x = 3 in" `like` [ - ParseError (Loc 1 13) "parse error (possibly incorrect indentation or mismatched brackets)" - ] - - it "breaks without data kinds" $ - parses "data X = 3" `like` [ - ParseError (Loc 1 10) "Illegal literal in type (use -XDataKinds to enable): 3" - ] - - it "parses statements after imports" $ do - parses "import X\nprint 3" `like` [ - Import "import X", - Expression "print 3" - ] - parses "import X\n\nprint 3" `like` [ - Import "import X", - Expression "print 3" - ] - it "ignores blank lines properly" $ - [hereLit| - test arg = hello - where - x = y - - z = w - |] `is` Declaration - it "doesn't break on long strings" $ do - let longString = concat $ replicate 20 "hello " - ("img ! src \"" ++ longString ++ "\" ! width \"500\"") `is` Expression - - it "parses do blocks in expression" $ do - [hereLit| - show (show (do - Just 10 - Nothing - Just 100)) - |] `is` Expression - diff --git a/IHaskell/Config.hs b/IHaskell/Config.hs deleted file mode 100644 --- a/IHaskell/Config.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} --- | Description : IPython configuration files are compiled-into IHaskell -module IHaskell.Config (ipython, notebook, console, qtconsole, customjs, notebookJavascript) where - -import Data.String.Here -import ClassyPrelude - -ipython :: String -> String -ipython executable = [template|config/ipython_config.py|] - -notebook :: String -notebook = [template|config/ipython_notebook_config.py|] - -console :: String -console = [template|config/ipython_console_config.py|] - -qtconsole :: String -qtconsole = [template|config/ipython_qtconsole_config.py|] - -customjs :: String -customjs = [template|config/custom.js|] - -notebookJavascript :: [(FilePath, String)] -notebookJavascript = [("tooltip.js", [template|deps/tooltip.js|]), - ("codecell.js", [template|deps/codecell.js|])] diff --git a/IHaskell/Display.hs b/IHaskell/Display.hs deleted file mode 100644 --- a/IHaskell/Display.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -module IHaskell.Display ( - IHaskellDisplay(..), - plain, html, png, jpg, svg, latex, - serializeDisplay - ) where - -import ClassyPrelude -import Data.Serialize as Serialize -import Data.ByteString -import Data.String.Utils (rstrip) - -import IHaskell.Types - --- | A class for displayable Haskell types. -class IHaskellDisplay a where - display :: a -> [DisplayData] - --- | Generate a plain text display. -plain :: String -> DisplayData -plain = Display PlainText . rstrip - --- | Generate an HTML display. -html :: String -> DisplayData -html = Display MimeHtml - -png :: String -> DisplayData -png = Display MimePng - -jpg :: String -> DisplayData -jpg = Display MimeJpg - -svg :: String -> DisplayData -svg = Display MimeSvg - -latex :: String -> DisplayData -latex = Display MimeLatex - -serializeDisplay :: [DisplayData] -> ByteString -serializeDisplay = Serialize.encode diff --git a/IHaskell/Eval/Completion.hs b/IHaskell/Eval/Completion.hs deleted file mode 100644 --- a/IHaskell/Eval/Completion.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} -{- | Description : generates tab-completion options - - context-insensitive completion for what is probably - the identifier under the cursor. - - [@Known issues@] - - > import Data.Lef - > System.IO.h - > Just.he - - The first should not complete to Left. The second should only - include things like System.IO.hPutStrLn, not head. Qualified - names should not be confused by the third option. - --} -module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where - -import Control.Applicative ((<$>)) -import Data.ByteString.UTF8 hiding (drop, take) -import Data.Char -import Data.List (find, isPrefixOf, nub, findIndex, intercalate, elemIndex) -import Data.List.Split -import Data.List.Split.Internals -import Data.Maybe -import Data.String.Utils (strip, startswith, replace) -import Prelude - -import GHC -import DynFlags -import GhcMonad -import PackageConfig -import Outputable (showPpr) - -import IHaskell.Types - - -data CompletionType - = Empty - | Identifier String - | Extension String - | Qualified String String - | ModuleName String String - deriving (Show, Eq) - -complete :: GHC.GhcMonad m => String -> Int -> m (String, [String]) -complete line pos = do - flags <- getSessionDynFlags - rdrNames <- map (showPpr flags) <$> getRdrNamesInScope - scopeNames <- nub <$> map (showPpr flags) <$> getNamesInScope - let isQualified = ('.' `elem`) - unqualNames = nub $ filter (not . isQualified) rdrNames - qualNames = nub $ scopeNames ++ filter isQualified rdrNames - - let Just db = pkgDatabase flags - getNames = map moduleNameString . exposedModules - moduleNames = nub $ concatMap getNames db - - let target = completionTarget line pos - matchedText = intercalate "." target - - options <- - case completionType line target of - Empty -> return [] - - Identifier candidate -> - return $ filter (candidate `isPrefixOf`) unqualNames - - Qualified moduleName candidate -> do - trueName <- getTrueModuleName moduleName - let prefix = intercalate "." [trueName, candidate] - completions = filter (prefix `isPrefixOf`) qualNames - falsifyName = replace trueName moduleName - return $ map falsifyName completions - - ModuleName previous candidate -> do - let prefix = if null previous - then candidate - else intercalate "." [previous, candidate] - return $ filter (prefix `isPrefixOf`) moduleNames - - Extension ext -> do - let extName (name, _, _) = name - names = map extName xFlags - nonames = map ("No" ++) names - return $ filter (ext `isPrefixOf`) $ names ++ nonames - - return (matchedText, options) - -getTrueModuleName :: GhcMonad m => String -> m String -getTrueModuleName name = do - -- Only use the things that were actually imported - let onlyImportDecl (IIDecl decl) = Just decl - onlyImportDecl _ = Nothing - - -- Get all imports that we use. - imports <- catMaybes <$> map onlyImportDecl <$> getContext - - -- Find the ones that have a qualified name attached. - -- If this name isn't one of them, it already is the true name. - flags <- getSessionDynFlags - let qualifiedImports = filter (isJust . ideclAs) imports - hasName imp = name == (showPpr flags . fromJust . ideclAs) imp - case find hasName qualifiedImports of - Nothing -> return name - Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp - -completionType :: String -> [String] -> CompletionType -completionType line [] = Empty -completionType line target - | startswith "import" stripped && isModName - = ModuleName dotted candidate - | isModName && (not . null . init) target - = Qualified dotted candidate - | startswith ":e" stripped - = Extension candidate - | otherwise - = Identifier candidate - where stripped = strip line - dotted = dots target - candidate = last target - dots = intercalate "." . init - isModName = all isCapitalized (init target) - isCapitalized = isUpper . head - - --- | Get the word under a given cursor location. -completionTarget :: String -> Int -> [String] -completionTarget code cursor = expandCompletionPiece pieceToComplete - where - pieceToComplete = map fst <$> find (elem cursor . map snd) pieces - pieces = splitAlongCursor $ split splitter $ zip code [1 .. ] - splitter = defaultSplitter { - -- Split using only the characters, which are the first elements of - -- the (char, index) tuple - delimiter = Delimiter [uncurry isDelim], - -- Condense multiple delimiters into one and then drop them. - condensePolicy = Condense, - delimPolicy = Drop - } - - isDelim char idx = char `elem` neverIdent || isSymbol char - - splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]] - splitAlongCursor [] = [] - splitAlongCursor (x:xs) = - case elemIndex cursor $ map snd x of - Nothing -> x:splitAlongCursor xs - Just idx -> take (idx + 1) x:drop (idx + 1) x:splitAlongCursor xs - - -- These are never part of an identifier. - neverIdent = " \n\t(),{}[]\\'\"`" - - expandCompletionPiece Nothing = [] - expandCompletionPiece (Just str) = splitOn "." str diff --git a/IHaskell/Eval/Evaluate.hs b/IHaskell/Eval/Evaluate.hs deleted file mode 100644 --- a/IHaskell/Eval/Evaluate.hs +++ /dev/null @@ -1,615 +0,0 @@ -{-# LANGUAGE DoAndIfThenElse #-} -{- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs - a statement, declaration, import, or directive. - -This module exports all functions used for evaluation of IHaskell input. --} -module IHaskell.Eval.Evaluate ( - interpret, evaluate, Interpreter, liftIO, typeCleaner, globalImports - ) where - -import ClassyPrelude hiding (liftIO, hGetContents) -import Control.Concurrent (forkIO, threadDelay) -import Prelude (putChar, head, tail, last, init, (!!)) -import Data.List.Utils -import Data.List(findIndex) -import Data.String.Utils -import Text.Printf -import Data.Char as Char -import Data.Dynamic -import Data.Typeable -import qualified Data.Serialize as Serialize -import System.Directory (removeFile, createDirectoryIfMissing, removeDirectoryRecursive) -import System.Posix.IO -import System.IO (hGetChar, hFlush) -import System.Random (getStdGen, randomRs) -import Unsafe.Coerce - -import NameSet -import Name -import PprTyThing -import InteractiveEval -import DynFlags -import Type -import Exception (gtry) -import HscTypes -import HscMain -import TcType -import Unify -import InstEnv -import GhcMonad (liftIO, withSession) -import GHC hiding (Stmt, TypeSig) -import GHC.Paths -import Exception hiding (evaluate) -import Outputable -import Packages -import Module - -import qualified System.IO.Strict as StrictIO - -import IHaskell.Types -import IHaskell.Eval.Parser -import IHaskell.Display - -data ErrorOccurred = Success | Failure deriving Show - -debug :: Bool -debug = False - -ignoreTypePrefixes :: [String] -ignoreTypePrefixes = ["GHC.Types", "GHC.Base", "GHC.Show", "System.IO", - "GHC.Float", ":Interactive", "GHC.Num", "GHC.IO", - "GHC.Integer.Type"] - -typeCleaner :: String -> String -typeCleaner = useStringType . foldl' (.) id (map (`replace` "") fullPrefixes) - where - fullPrefixes = map (++ ".") ignoreTypePrefixes - useStringType = replace "[Char]" "String" - -write :: GhcMonad m => String -> m () -write x = when debug $ liftIO $ hPutStrLn stderr x - -type Interpreter = Ghc - -globalImports :: [String] -globalImports = - [ "import IHaskell.Display" - , "import Control.Applicative ((<$>))" - , "import GHC.IO.Handle (hDuplicateTo, hDuplicate)" - , "import System.Posix.IO" - , "import System.Posix.Files" - , "import System.IO" - ] - --- | Run an interpreting action. This is effectively runGhc with --- initialization and importing. -interpret :: Interpreter a -> IO a -interpret action = runGhc (Just libdir) $ do - -- Set the dynamic session flags - originalFlags <- getSessionDynFlags - let dflags = xopt_set originalFlags Opt_ExtendedDefaultRules - void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted, ghcLink = LinkInMemory } - - initializeImports - initializeItVariable - - -- Run the rest of the interpreter - action - --- | Initialize our GHC session with imports and a value for 'it'. -initializeImports :: Interpreter () -initializeImports = do - -- Load packages that start with ihaskell-* and aren't just IHaskell. - dflags <- getSessionDynFlags - displayPackages <- liftIO $ do - (dflags, _) <- initPackages dflags - let Just db = pkgDatabase dflags - packageNames = map (packageIdString . packageConfigId) db - initStr = "ihaskell-" - ihaskellPkgs = filter (startswith initStr) packageNames - displayPkgs = filter (isAlpha . (!! (length initStr + 1))) ihaskellPkgs - return displayPkgs - - -- Generate import statements all Display modules. - let capitalize :: String -> String - capitalize (first:rest) = Char.toUpper first : rest - - importFmt = "import IHaskell.Display.%s" - - toImportStmt :: String -> String - toImportStmt = printf importFmt . capitalize . (!! 1) . split "-" - - displayImports = map toImportStmt displayPackages - - -- Import implicit prelude. - importDecl <- parseImportDecl "import Prelude" - let implicitPrelude = importDecl { ideclImplicit = True } - - -- Import modules. - mapM_ (write . ("Importing " ++ )) displayImports - imports <- mapM parseImportDecl $ globalImports ++ displayImports - setContext $ map IIDecl $ implicitPrelude : imports - --- | Give a value for the `it` variable. -initializeItVariable :: Interpreter () -initializeItVariable = - -- This is required due to the way we handle `it` in the wrapper - -- statements - if it doesn't exist, the first statement will fail. - void $ runStmt "let it = ()" RunToCompletion - --- | Publisher for IHaskell outputs. The first argument indicates whether --- this output is final (true) or intermediate (false). -type Publisher = (Bool -> [DisplayData] -> IO ()) - --- | Evaluate some IPython input code. -evaluate :: Int -- ^ The execution counter of this evaluation. - -> String -- ^ Haskell code or other interpreter commands. - -> Publisher -- ^ Function used to publish data outputs. - -> Interpreter () -evaluate execCount code output = do - cmds <- parseString (strip code) - runUntilFailure (cmds ++ [storeItCommand execCount]) - where - runUntilFailure :: [CodeBlock] -> Interpreter () - runUntilFailure [] = return () - runUntilFailure (cmd:rest) = do - (success, result) <- evalCommand output cmd - unless (null result) $ liftIO $ output True result - case success of - Success -> runUntilFailure rest - Failure -> return () - - storeItCommand execCount = Statement $ printf "let it%d = it" execCount - -wrapExecution :: Interpreter [DisplayData] -> Interpreter (ErrorOccurred, [DisplayData]) -wrapExecution exec = ghandle handler $ exec >>= \res -> - return (Success, res) - where - handler :: SomeException -> Interpreter (ErrorOccurred, [DisplayData]) - handler exception = return (Failure, displayError $ show exception) - --- | Return the display data for this command, as well as whether it --- resulted in an error. -evalCommand :: Publisher -> CodeBlock -> Interpreter (ErrorOccurred, [DisplayData]) -evalCommand _ (Import importStr) = wrapExecution $ 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 - - flags <- getSessionDynFlags - return [] - where - implicitImportOf :: ImportDecl RdrName -> InteractiveImport -> Bool - implicitImportOf _ (IIModule _) = False - implicitImportOf imp (IIDecl decl) = ideclImplicit decl && ((==) `on` (unLoc . ideclName)) decl imp - -evalCommand _ (Module contents) = wrapExecution $ do - write $ "Module:\n" ++ contents - -- Write the module contents to a temporary file in our work directory - namePieces <- getModuleName contents - let directory = "./" ++ intercalate "/" (init namePieces) ++ "/" - filename = last namePieces ++ ".hs" - liftIO $ do - createDirectoryIfMissing True directory - writeFile (fpFromString $ directory ++ filename) contents - - -- Clear old modules of this name - let modName = intercalate "." namePieces - removeTarget $ TargetModule $ mkModuleName modName - removeTarget $ TargetFile filename Nothing - - -- Set to use object code for fast running times, as that is the only - -- reason you would want to use modules in IHaskell. - flags <- getSessionDynFlags - let objTarget = defaultObjectTarget - setSessionDynFlags flags{ hscTarget = objTarget } - - -- Remember which modules we've loaded before. - importedModules <- getContext - - let -- Get the dot-delimited pieces of hte module name. - moduleNameOf :: InteractiveImport -> [String] - moduleNameOf (IIDecl decl) = split "." . moduleNameString . unLoc . ideclName $ decl - moduleNameOf (IIModule imp) = split "." . moduleNameString $ imp - - -- Return whether this module prevents the loading of the one we're - -- trying to load. If a module B exist, we cannot load A.B. All - -- modules must have unique last names (where A.B has last name B). - -- However, we *can* just reload a module. - preventsLoading mod = - let pieces = moduleNameOf mod in - last namePieces == last pieces && namePieces /= pieces - - -- If we've loaded anything with the same last name, we can't use this. - -- Otherwise, GHC tries to load the original *.hs fails and then fails. - case find preventsLoading importedModules of - -- If something prevents loading this module, return an error. - Just previous -> - let prevLoaded = intercalate "." (moduleNameOf previous) in - return $ displayError $ - printf "Can't load module %s because already loaded %s" modName prevLoaded - - -- Since nothing prevents loading the module, compile and load it. - Nothing -> do - -- Create a new target - target <- guessTarget modName Nothing - addTarget target - result <- load LoadAllTargets - - -- Reset the context, since loading things screws it up. - initializeItVariable - - -- Add imports - importDecl <- parseImportDecl $ "import " ++ modName - let implicitImport = importDecl { ideclImplicit = True } - setContext $ IIDecl implicitImport : importedModules - - -- Switch back to interpreted mode. - flags <- getSessionDynFlags - setSessionDynFlags flags{ hscTarget = HscInterpreted } - - case result of - Succeeded -> return [] - Failed -> return $ displayError $ "Failed to load module " ++ modName - -evalCommand _ (Directive SetExtension exts) = wrapExecution $ do - write $ "Extension: " ++ exts - results <- mapM setExtension (words exts) - case catMaybes results of - [] -> return [] - errors -> return $ displayError $ intercalate "\n" errors - where - -- Set an extension and update flags. - -- Return Nothing on success. On failure, return an error message. - setExtension :: String -> Interpreter (Maybe ErrMsg) - setExtension ext = do - flags <- getSessionDynFlags - -- First, try to check if this flag matches any extension name. - let newFlags = - case find (flagMatches ext) xFlags of - Just (_, flag, _) -> Just $ xopt_set flags flag - -- If it doesn't match an extension name, try matching against - -- disabling an extension. - Nothing -> - case find (flagMatchesNo ext) xFlags of - Just (_, flag, _) -> Just $ xopt_unset flags flag - Nothing -> Nothing - - -- Set the flag if we need to. - case newFlags of - Just flags -> setSessionDynFlags flags >> return Nothing - Nothing -> return $ Just $ "Could not parse extension name: " ++ ext - - -- Check if a FlagSpec matches an extension name. - flagMatches ext (name, _, _) = ext == name - - -- Check if a FlagSpec matches "No". - -- In that case, we disable the extension. - flagMatchesNo ext (name, _, _) = ext == "No" ++ name - -evalCommand _ (Directive GetType expr) = wrapExecution $ do - write $ "Type: " ++ expr - result <- exprType expr - flags <- getSessionDynFlags - let typeStr = showSDocUnqual flags $ ppr result - return [plain typeStr, html $ formatGetType typeStr] - --- This is taken largely from GHCi's info section in InteractiveUI. -evalCommand _ (Directive HelpForSet _) = do - write "Help for :set." - return (Success, [out]) - where out = plain $ intercalate "\n" - [":set is not implemented in IHaskell." - ," Use :extension to enable a GHC extension." - ," Use :extension No to disable a GHC extension." - ] - --- This is taken largely from GHCi's info section in InteractiveUI. -evalCommand _ (Directive GetHelp _) = do - write "Help via :help or :?." - return (Success, [out]) - where out = plain $ intercalate "\n" - ["The following commands are available:" - ," :extension - enable a GHC extension." - ," :extension No - disable a GHC extension." - ," :type - Print expression type." - ," :info - Print all info for a name." - ," :?, :help - Show this help text." - ,"" - ,"Any prefix of the commands will also suffice, e.g. use :ty for :type." - ] - --- This is taken largely from GHCi's info section in InteractiveUI. -evalCommand _ (Directive GetInfo str) = wrapExecution $ do - write $ "Info: " ++ str - -- Get all the info for all the names we're given. - names <- parseName str - maybeInfos <- mapM getInfo names - - -- Filter out types that have parents in the same set. - -- GHCi also does this. - let getType (theType, _, _) = theType - infos = catMaybes maybeInfos - allNames = mkNameSet $ map (getName . getType) infos - hasParent info = case tyThingParent_maybe (getType info) of - Just parent -> getName parent `elemNameSet` allNames - Nothing -> False - filteredOutput = filter (not . hasParent) infos - - -- Convert to textual data. - let printInfo (thing, fixity, classInstances) = - pprTyThingInContextLoc False thing $$ showFixity fixity $$ vcat (map GHC.pprInstance classInstances) - where - showFixity fixity = - if fixity == GHC.defaultFixity - then empty - else ppr fixity <+> pprInfixName (getName thing) - outs = map printInfo filteredOutput - - -- Print nicely. - unqual <- getPrintUnqual - flags <- getSessionDynFlags - let strings = map (showSDocForUser flags unqual) outs - return [plain $ intercalate "\n" strings] - -evalCommand output (Statement stmt) = wrapExecution $ do - write $ "Statement:\n" ++ stmt - let outputter str = output False [plain str] - (printed, result) <- capturedStatement outputter stmt - case result of - RunOk names -> do - dflags <- getSessionDynFlags - write $ "Names: " ++ show (map (showPpr dflags) names) - let output = [plain printed | not . null $ strip printed] - return output - RunException exception -> throw exception - RunBreak{} -> error "Should not break." - -evalCommand output (Expression expr) = do - write $ "Expression:\n" ++ expr - -- Evaluate this expression as though it's just a statement. - -- The output is bound to 'it', so we can then use it. - (success, out) <- evalCommand output (Statement expr) - - -- Try to use `display` to convert our type into the output - -- DisplayData. If typechecking fails and there is no appropriate - -- typeclass, this will throw an exception and thus `attempt` will - -- return False, and we just resort to plaintext. - let displayExpr = printf "(IHaskell.Display.display (%s))" expr - canRunDisplay <- attempt $ exprType displayExpr - write $ printf "%s: Attempting %s" (if canRunDisplay then "Success" else "Failure") displayExpr - write $ "Show Error: " ++ show (isShowError out) - write $ show out - - -- If evaluation failed, return the failure. If it was successful, we - -- may be able to use the IHaskellDisplay typeclass. - if not canRunDisplay - then return (success, out) - else case success of - Success -> useDisplay displayExpr - Failure -> if isShowError out - then useDisplay displayExpr - else return (success, out) - - where - -- Try to evaluate an action. Return True if it succeeds and False if - -- it throws an exception. The result of the action is discarded. - attempt :: Interpreter a -> Interpreter Bool - attempt action = gcatch (action >> return True) failure - where failure :: SomeException -> Interpreter Bool - failure _ = return False - - -- Check if the error is due to trying to print something that doesn't - -- implement the Show typeclass. - isShowError errs = case find isPlain errs of - Just (Display PlainText msg) -> - startswith "No instance for (GHC.Show.Show" msg && - isInfixOf " arising from a use of `System.IO.print'" msg - Nothing -> False - where isPlain (Display mime _) = mime == PlainText - - useDisplay displayExpr = wrapExecution $ do - -- If there are instance matches, convert the object into - -- a [DisplayData]. We also serialize it into a bytestring. We get - -- the bytestring as a dynamic and then convert back to - -- a bytestring, which we promptly unserialize. Note that - -- attempting to do this without the serialization to binary and - -- back gives very strange errors - all the types match but it - -- refuses to decode back into a [DisplayData]. - runStmt displayExpr RunToCompletion - displayedBytestring <- dynCompileExpr "IHaskell.Display.serializeDisplay it" - case fromDynamic displayedBytestring of - Nothing -> error "Expecting lazy Bytestring" - Just bytestring -> - case Serialize.decode bytestring of - Left err -> error err - Right displayData -> do - write $ show displayData - return displayData - - -evalCommand _ (Declaration decl) = wrapExecution $ do - write $ "Declaration:\n" ++ decl - runDecls decl - - -- Do not display any output - return [] - -evalCommand _ (TypeSignature sig) = wrapExecution $ - -- We purposefully treat this as a "success" because that way execution - -- continues. Empty type signatures are likely due to a parse error later - -- on, and we want that to be displayed. - return $ displayError $ "The type signature " ++ sig ++ - "\nlacks an accompanying binding." - -evalCommand _ (ParseError loc err) = do - write "Parse Error." - return (Failure, displayError $ formatParseError loc err) - -capturedStatement :: (String -> IO ()) -- ^ Function used to publish intermediate output. - -> String -- ^ Statement to evaluate. - -> Interpreter (String, RunResult) -- ^ Return the output and result. -capturedStatement output stmt = do - -- Generate random variable names to use so that we cannot accidentally - -- override the variables by using the right names in the terminal. - gen <- liftIO getStdGen - let - -- Variable names generation. - rand = take 20 $ randomRs ('0', '9') gen - var name = name ++ rand - - -- Variables for the pipe input and outputs. - readVariable = var "file_read_var_" - writeVariable = var "file_write_var_" - - -- Variable where to store old stdout. - oldVariable = var "old_var_" - - -- Variable used to store true `it` value. - itVariable = var "it_var_" - - voidpf str = printf $ str ++ " >> return ()" - - -- 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 "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 - , printf "let it = %s" itVariable - ] - pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable - - goStmt s = runStmt s RunToCompletion - - -- Initialize evaluation context. - forM_ initStmts goStmt - - -- Get the pipe to read printed output from. - -- This is effectively the source code of dynCompileExpr from GHC API's - -- InteractiveEval. However, instead of using a `Dynamic` as an - -- intermediary, it just directly reads the value. This is incredibly - -- unsafe! However, for some reason the `getContext` and `setContext` - -- required by dynCompileExpr (to import and clear Data.Dynamic) cause - -- issues with data declarations being updated (e.g. it drops newer - -- versions of data declarations for older ones for unknown reasons). - -- First, compile down to an HValue. - Just (_, hValues, _) <- withSession $ liftIO . flip hscStmt pipeExpr - -- Then convert the HValue into an executable bit, and read the value. - pipe <- liftIO $ do - fd <- head <$> unsafeCoerce hValues - fdToHandle fd - - -- Read from a file handle until we hit a delimiter or until we've read - -- as many characters as requested - let - readChars :: Handle -> String -> Int -> IO String - - -- If we're done reading, return nothing. - readChars handle delims 0 = return [] - - readChars handle delims nchars = do - -- Try reading a single character. It will throw an exception if the - -- handle is already closed. - tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char) - case tryRead of - Right char -> - -- If this is a delimiter, stop reading. - if char `elem` delims - then return [char] - else do - next <- readChars handle delims (nchars - 1) - return $ char:next - -- An error occurs at the end of the stream, so just stop reading. - Left _ -> return [] - - -- Keep track of whether execution has completed. - completed <- liftIO $ newMVar False - finishedReading <- liftIO newEmptyMVar - outputAccum <- liftIO $ newMVar "" - - -- Start a loop to publish intermediate results. - let - -- Compute how long to wait between reading pieces of the output. - -- `threadDelay` takes an argument of microseconds. - ms = 1000 - delay = 100 * ms - - -- How much to read each time. - chunkSize = 100 - - -- Maximum size of the output (after which we truncate). - maxSize = 100 * 1000 - - loop = do - -- Wait and then check if the computation is done. - threadDelay delay - computationDone <- readMVar completed - - if not computationDone - then do - -- Read next chunk and append to accumulator. - nextChunk <- readChars pipe "\n" 100 - modifyMVar_ outputAccum (return . (++ nextChunk)) - - -- Write to frontend and repeat. - readMVar outputAccum >>= output - loop - else do - -- Read remainder of output and accumulate it. - nextChunk <- readChars pipe "" maxSize - modifyMVar_ outputAccum (return . (++ nextChunk)) - - -- We're done reading. - putMVar finishedReading True - - liftIO $ forkIO loop - - result <- gfinally (goStmt stmt) $ do - -- Execution is done. - liftIO $ modifyMVar_ completed (const $ return True) - - -- Finalize evaluation context. - forM_ postStmts goStmt - - -- Once context is finalized, reading can finish. - -- Wait for reading to finish to that the output accumulator is - -- completely filled. - liftIO $ takeMVar finishedReading - - printedOutput <- liftIO $ readMVar outputAccum - return (printedOutput, result) - -formatError :: ErrMsg -> String -formatError = printf "%s" . - replace "\n" "
" . - replace useDashV "" . - rstrip . - typeCleaner - where - useDashV = "\nUse -v to see a list of the files searched for." - -formatParseError :: StringLoc -> String -> ErrMsg -formatParseError (Loc line col) = - printf "Parse error (line %d, column %d): %s" line col - -formatGetType :: String -> String -formatGetType = printf "%s" - -displayError :: ErrMsg -> [DisplayData] -displayError msg = [plain msg, html $ formatError msg] diff --git a/IHaskell/Eval/Info.hs b/IHaskell/Eval/Info.hs deleted file mode 100644 --- a/IHaskell/Eval/Info.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} -{- | Description : Inspect type and function information and documentation. --} -module IHaskell.Eval.Info ( - info - ) where - -import ClassyPrelude hiding (liftIO) - -import IHaskell.Eval.Evaluate (typeCleaner, Interpreter) - -import GHC -import Outputable -import Exception - -info :: String -> Interpreter String -info name = ghandle handler $ do - dflags <- getSessionDynFlags - result <- exprType name - return $ typeCleaner $ showPpr dflags result - where - handler :: SomeException -> Interpreter String - handler _ = return "" diff --git a/IHaskell/Eval/Parser.hs b/IHaskell/Eval/Parser.hs deleted file mode 100644 --- a/IHaskell/Eval/Parser.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} -module IHaskell.Eval.Parser ( - parseString, - CodeBlock(..), - StringLoc(..), - DirectiveType(..), - LineNumber, - ColumnNumber, - ErrMsg, - layoutChunks, - parseDirective, - getModuleName - ) where - --- Hide 'unlines' to use our own 'joinLines' instead. -import ClassyPrelude hiding (liftIO, unlines) - -import Data.List (findIndex, maximumBy, maximum, inits) -import Data.String.Utils (startswith, strip, split) -import Data.List.Utils (subIndex) -import Prelude (init, last, head, tail) - -import Bag -import ErrUtils hiding (ErrMsg) -import FastString -import GHC -import Lexer -import OrdList -import Outputable hiding ((<>)) -import SrcLoc -import StringBuffer - -import Language.Haskell.GHC.Parser - --- | A block of code to be evaluated. --- Each block contains a single element - one declaration, statement, --- expression, etc. If parsing of the block failed, the block is instead --- a ParseError, which has the error location and error message. -data CodeBlock - = Expression String -- ^ A Haskell expression. - | Declaration String -- ^ A data type or function declaration. - | Statement String -- ^ A Haskell statement (as if in a `do` block). - | Import String -- ^ An import statement. - | TypeSignature String -- ^ A lonely type signature (not above a function declaration). - | Directive DirectiveType String -- ^ An IHaskell directive. - | Module String -- ^ A full Haskell module, to be compiled and loaded. - | ParseError StringLoc ErrMsg -- ^ An error indicating that parsing the code block failed. - deriving (Show, Eq) - --- | Directive types. Each directive is associated with a string in the --- directive code block. -data DirectiveType - = GetType -- ^ Get the type of an expression via ':type' (or unique prefixes) - | GetInfo -- ^ Get info about the identifier via ':info' (or unique prefixes) - | SetExtension -- ^ Enable or disable an extension via ':extension' (or prefixes) - | HelpForSet -- ^ Provide useful info if people try ':set'. - | GetHelp -- ^ General help via ':?' or ':help'. - deriving (Show, Eq) - --- | Parse a string into code blocks. -parseString :: GhcMonad m => String -> m [CodeBlock] -parseString codeString = do - -- Try to parse this as a single module. - flags <- getSessionDynFlags - let output = runParser flags parserModule codeString - case output of - Parsed {} -> return [Module codeString] - Failure {} -> - -- Split input into chunks based on indentation. - let chunks = layoutChunks $ dropComments codeString in - joinFunctions <$> processChunks 1 [] chunks - where - parseChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock - parseChunk chunk line = - if isDirective chunk - then return $ parseDirective chunk line - else parseCodeChunk chunk line - - processChunks :: GhcMonad m => LineNumber -> [CodeBlock] -> [String] -> m [CodeBlock] - processChunks line accum remaining = - case remaining of - -- If we have no more remaining lines, return the accumulated results. - [] -> return $ reverse accum - - -- If we have more remaining, parse the current chunk and recurse. - chunk:remaining -> do - block <- parseChunk chunk line - processChunks (line + nlines chunk) (block : accum) remaining - - -- Test wither a given chunk is a directive. - isDirective :: String -> Bool - isDirective = startswith ":" . strip - - -- Number of lines in this string. - nlines :: String -> Int - nlines = length . lines - --- | Parse a single chunk of code, as indicated by the layout of the code. -parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock -parseCodeChunk code startLine = do - flags <- getSessionDynFlags - let - -- Try each parser in turn. - rawResults = map (tryParser code) (parsers flags) - - -- Convert statements into expressions where we can - results = map (statementToExpression flags) rawResults in - case successes results of - -- If none of them succeeded, choose the best error message to - -- display. Only one of the error messages is actually relevant. - [] -> return $ bestError $ failures results - - -- If one of the parsers succeeded - result:_ -> return result - where - successes :: [ParseOutput a] -> [a] - successes [] = [] - successes (Parsed a:rest) = a : successes rest - successes (_:rest) = successes rest - - failures :: [ParseOutput a] -> [(ErrMsg, LineNumber, ColumnNumber)] - failures [] = [] - failures (Failure msg (Loc line col):rest) = (msg, line, col) : failures rest - failures (_:rest) = failures rest - - bestError :: [(ErrMsg, LineNumber, ColumnNumber)] -> CodeBlock - bestError errors = ParseError (Loc (line + startLine - 1) col) msg - where - (msg, line, col) = maximumBy compareLoc errors - compareLoc (_, line1, col1) (_, line2, col2) = compare line1 line2 <> compare col1 col2 - - statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock - statementToExpression flags (Parsed (Statement stmt)) = Parsed result - where result = if isExpr flags stmt - then Expression stmt - else Statement stmt - statementToExpression _ other = other - - -- Check whether a string is a valid expression. - isExpr :: DynFlags -> String -> Bool - isExpr flags str = case runParser flags parserExpression str of - Parsed {} -> True - _ -> False - - tryParser :: String -> (String -> CodeBlock, String -> ParseOutput String) -> ParseOutput CodeBlock - tryParser string (blockType, parser) = case parser string of - Parsed res -> Parsed (blockType res) - Failure err loc -> Failure err loc - - parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)] - parsers flags = - [ (Import, unparser parserImport) - , (TypeSignature, unparser parserTypeSignature) - , (Declaration, unparser parserDeclaration) - , (Statement, unparser parserStatement) - ] - where - unparser :: Parser a -> String -> ParseOutput String - unparser parser code = - case runParser flags parser code of - Parsed out -> Parsed code - Partial out strs -> Partial code strs - Failure err loc -> Failure err loc - --- | Find consecutive declarations of the same function and join them into --- a single declaration. These declarations may also include a type --- signature, which is also joined with the subsequent declarations. -joinFunctions :: [CodeBlock] -> [CodeBlock] -joinFunctions (Declaration decl : rest) = - -- Find all declarations having the same name as this one. - let (decls, other) = havingSameName rest in - -- Convert them into a single declaration. - Declaration (joinLines $ map undecl decls) : joinFunctions other - where - undecl (Declaration decl) = decl - undecl _ = error "Expected declaration!" - - -- Get all declarations with the same name as the first declaration. - -- The name of a declaration is the first word, which we expect to be - -- the name of the function. - havingSameName :: [CodeBlock] -> ([CodeBlock], [CodeBlock]) - havingSameName blocks = - let name = head $ words decl - sameName = takeWhile (isNamedDecl name) rest - others = drop (length sameName) rest in - (Declaration decl : sameName, others) - - isNamedDecl :: String -> CodeBlock -> Bool - isNamedDecl name (Declaration dec) = head (words dec) == name - isNamedDecl _ _ = False - --- Allow a type signature followed by declarations to be joined to the --- declarations. Parse the declaration joining separately. -joinFunctions (TypeSignature sig : Declaration decl : rest) = (Declaration $ sig ++ "\n" ++ joinedDecl):remaining - where Declaration joinedDecl:remaining = joinFunctions $ Declaration decl : rest - -joinFunctions (x:xs) = x : joinFunctions xs -joinFunctions [] = [] - - --- | Parse a directive of the form :directiveName. -parseDirective :: String -- ^ Directive string. - -> Int -- ^ Line number at which the directive appears. - -> CodeBlock -- ^ Directive code block or a parse error. -parseDirective (':':directive) line = case find rightDirective directives of - Just (directiveType, _) -> Directive directiveType arg - where arg = unwords restLine - _:restLine = words directive - Nothing -> - let directiveStart = case words directive of - [] -> "" - first:_ -> first in - ParseError (Loc line 1) $ "Unknown directive: '" ++ directiveStart ++ "'." - where - rightDirective (_, dirname) = case words directive of - [] -> False - dir:_ -> dir `elem` tail (inits dirname) - directives = - [(GetType, "type") - ,(GetInfo, "info") - ,(SetExtension, "extension") - ,(HelpForSet, "set") - ,(GetHelp, "?") - ,(GetHelp, "help") - ] -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 -> [String] -layoutChunks string = filter (not . null) $ map strip $ layoutLines $ lines string - where - layoutLines :: [String] -> [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 (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 -> [string] - - -- We found the end of the block. Split this bit out and recurse. - Just idx -> - joinLines (firstLine:take idx rest) : layoutChunks (joinLines $ drop idx rest) - - -- 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 - 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. -getModuleName :: GhcMonad m => String -> m [String] -getModuleName moduleSrc = do - flags <- getSessionDynFlags - let output = runParser flags parserModule moduleSrc - case output of - Failure {} -> error "Module parsing failed." - Parsed mod -> - case unLoc <$> hsmodName (unLoc mod) of - Nothing -> error "Module must have a name." - Just name -> return $ split "." $ moduleNameString name diff --git a/IHaskell/IPython.hs b/IHaskell/IPython.hs deleted file mode 100644 --- a/IHaskell/IPython.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} -{-# LANGUAGE DoAndIfThenElse #-} --- | Description : Shell scripting wrapper using @Shelly@ for the @notebook@, @setup@, and --- @console@ commands. -module IHaskell.IPython ( - ipythonInstalled, - installIPython, - removeIPython, - runConsole, - runNotebook, - readInitInfo, - defaultConfFile, -) where - -import ClassyPrelude -import Prelude (read, reads, init) -import Shelly hiding (find, trace, path) -import System.Argv0 -import System.Directory -import qualified Filesystem.Path.CurrentOS as FS -import Data.List.Utils (split) -import Data.String.Utils (rstrip) -import Text.Printf - -import qualified System.IO.Strict as StrictIO -import qualified Paths_ihaskell as Paths -import qualified Codec.Archive.Tar as Tar - -import IHaskell.Types - --- | Which commit of IPython we are on. -ipythonCommit :: Text -ipythonCommit = "1faf2f6e77fa31f4533e3edbe101c38ddf8943d8" - --- | The IPython profile name. -ipythonProfile :: String -ipythonProfile = "haskell" - --- | Run IPython with any arguments. -ipython :: Bool -- ^ Whether to suppress output. - -> [Text] -- ^ IPython command line arguments. - -> Sh String -- ^ IPython output. -ipython suppress args = do - (_, ipythonDir, _) <- ihaskellDirs - let ipythonPath = fromText $ ipythonDir ++ "/bin/ipython" - sub $ do - setenv "PYTHONPATH" $ ipythonDir ++ "/lib/python2.7/site-packages" - runHandles ipythonPath args handles doNothing - where handles = [InHandle Inherit, outHandle suppress, errorHandle suppress] - outHandle True = OutHandle CreatePipe - outHandle False = OutHandle Inherit - errorHandle True = ErrorHandle CreatePipe - errorHandle False = ErrorHandle Inherit - doNothing _ stdout _ = if suppress - then liftIO $ StrictIO.hGetContents stdout - else return "" - --- | Run while suppressing all output. -quietRun path args = runHandles path args handles nothing - where - handles = [InHandle Inherit, OutHandle CreatePipe, ErrorHandle CreatePipe] - nothing _ _ _ = return () - --- | Return the data directory for IHaskell and the IPython subdirectory. -ihaskellDirs :: Sh (Text, Text, Text) -ihaskellDirs = do - home <- maybe (error "$HOME not defined.") id <$> get_env "HOME" :: Sh Text - let ihaskellDir = home ++ "/.ihaskell" - ipythonDir = ihaskellDir ++ "/ipython" - notebookDir = ihaskellDir ++ "/notebooks" - - -- Make sure the directories exist. - mkdir_p $ fromText ipythonDir - mkdir_p $ fromText notebookDir - - return (ihaskellDir, ipythonDir, notebookDir) - -defaultConfFile :: IO (Maybe String) -defaultConfFile = shellyNoDir $ do - (ihaskellDir, _, _) <- ihaskellDirs - let filename = ihaskellDir ++ "/rc.hs" - exists <- test_f $ fromText filename - return $ if exists - then Just $ unpack filename - else Nothing - --- | Remove IPython so it can be reinstalled. -removeIPython :: IO () -removeIPython = void . shellyNoDir $ do - (ihaskellDir, _, _) <- ihaskellDirs - cd $ fromText ihaskellDir - rm_rf "ipython-src" - --- | Install IPython from source. -installIPython :: IO () -installIPython = void . shellyNoDir $ do - (ihaskellDir, ipythonDir, _) <- ihaskellDirs - - -- Install all Python dependencies. - pipPath <- path "pip" - let pipDeps = ["pyzmq", "tornado", "jinja2"] - installDep dep = do - putStrLn $ "Installing dependency: " ++ dep - let opt = "--install-option=--prefix=" ++ ipythonDir - run_ pipPath ["install", opt, dep] - mapM_ installDep pipDeps - - -- Get the IPython source. - gitPath <- path "git" - putStrLn "Downloading IPython... (this may take a while)" - cd $ fromText ihaskellDir - run_ gitPath ["clone", "--recursive", "https://github.com/ipython/ipython.git", "ipython-src"] - cd "ipython-src" - run_ gitPath ["checkout", ipythonCommit] - - -- Install IPython locally. - pythonPath <- path "python" - putStrLn "Installing IPython." - run_ pythonPath ["setup.py", "install", "--prefix=" ++ ipythonDir] - cd ".." - --- | Check whether IPython is properly installed. -ipythonInstalled :: IO Bool -ipythonInstalled = shellyNoDir $ do - (_, ipythonDir, _) <- ihaskellDirs - let ipythonPath = ipythonDir ++ "/bin/ipython" - test_f $ fromText ipythonPath - --- | Get the path to an executable. If it doensn't exist, fail with an --- error message complaining about it. -path :: Text -> Sh FilePath -path exe = do - path <- which $ fromText exe - case path of - Nothing -> do - putStrLn $ "Could not find `" ++ exe ++ "` executable." - fail $ "`" ++ unpack exe ++ "` not on $PATH." - Just exePath -> return exePath - --- | Use the `ipython --version` command to figure out the version. --- Return a tuple with (major, minor, patch). -ipythonVersion :: IO (Int, Int, Int) -ipythonVersion = shellyNoDir $ do - [major, minor, patch] <- parseVersion <$> ipython True ["--version"] - return (major, minor, patch) - --- | Parse an IPython version string into a list of integers. -parseVersion :: String -> [Int] -parseVersion versionStr = map read' $ split "." versionStr - where read' x = case reads x of - [(n, _)] -> n - _ -> error $ "cannot parse version: "++ versionStr - --- | Run an IHaskell application using the given profile. -runIHaskell :: String -- ^ IHaskell profile name. - -> String -- ^ IPython app name. - -> [String] -- ^ Arguments to IPython. - -> Sh () -runIHaskell profile app args = void $ do - -- Try to locate the profile. Do not die if it doesn't exist. - errExit False $ ipython True ["locate", "profile", pack profile] - - -- If the profile doesn't exist, create it. - exitCode <- lastExitCode - when (exitCode /= 0) $ liftIO $ do - putStrLn "Creating IPython profile." - setupIPythonProfile profile - - -- Run the IHaskell command. - ipython False $ map pack $ [app, "--profile", profile] ++ args - -runConsole :: InitInfo -> IO () -runConsole initInfo = void . shellyNoDir $ do - writeInitInfo initInfo - runIHaskell ipythonProfile "console" [] - -runNotebook :: InitInfo -> Maybe String -> IO () -runNotebook initInfo maybeServeDir = void . shellyNoDir $ do - (_, _, notebookDir) <- ihaskellDirs - let args = case maybeServeDir of - Nothing -> ["--notebook-dir", unpack notebookDir] - Just dir -> ["--notebook-dir", dir] - - writeInitInfo initInfo - runIHaskell ipythonProfile "notebook" args - -writeInitInfo :: InitInfo -> Sh () -writeInitInfo info = do - (ihaskellDir, _, _) <- ihaskellDirs - let filename = fromText $ ihaskellDir ++ "/last-arguments" - liftIO $ writeFile filename $ show info - -readInitInfo :: IO InitInfo -readInitInfo = shellyNoDir $ do - (ihaskellDir, _, _) <- ihaskellDirs - let filename = fromText $ ihaskellDir ++ "/last-arguments" - read <$> liftIO (readFile filename) - --- | Create the IPython profile. -setupIPythonProfile :: String -- ^ IHaskell profile name. - -> IO () -setupIPythonProfile profile = shellyNoDir $ do - -- Create the IPython profile. - void $ ipython True ["profile", "create", pack profile] - - -- Find the IPython profile directory. Make sure to get rid of trailing - -- newlines from the output of the `ipython locate` call. - ipythonDir <- pack <$> rstrip <$> ipython True ["locate"] - let profileDir = ipythonDir ++ "/profile_" ++ pack profile ++ "/" - - liftIO $ copyProfile profileDir - insertIHaskellPath profileDir - --- | Copy the profile files into the IPython profile. -copyProfile :: Text -> IO () -copyProfile profileDir = do - profileTar <- Paths.getDataFileName "profile/profile.tar" - {- - -- Load profile from Resources directory of Mac *.app. - ihaskellPath <- shellyNoDir getIHaskellPath - profileTar <- if "IHaskell.app/Contents/MacOS" `isInfixOf` ihaskellPath - then - let pieces = split "/" ihaskellPath - pathPieces = init pieces ++ ["..", "Resources", "profile.tar"] in - return $ intercalate "/" pathPieces - else Paths.getDataFileName "profile/profile.tar" - -} - putStrLn $ pack $ "Loading profile from " ++ profileTar - Tar.extract (unpack profileDir) profileTar - --- | Insert the IHaskell path into the IPython configuration. -insertIHaskellPath :: Text -> Sh () -insertIHaskellPath profileDir = do - path <- getIHaskellPath - let filename = profileDir ++ "ipython_config.py" - template = "exe = '%s'.replace(' ', '\\\\ ')" - exeLine = printf template $ unpack path :: String - - liftIO $ do - contents <- StrictIO.readFile $ unpack filename - writeFile (fromText filename) $ exeLine ++ "\n" ++ contents - --- | Get the absolute path to this IHaskell executable. -getIHaskellPath :: Sh String -getIHaskellPath = do - -- Get the absolute filepath to the argument. - f <- liftIO getArgv0 - - -- If we have an absolute path, that's the IHaskell we're interested in. - if FS.absolute f - then return $ FS.encodeString f - else - -- Check whether this is a relative path, or just 'IHaskell' with $PATH - -- resolution done by the shell. If it's just 'IHaskell', use the $PATH - -- variable to find where IHaskell lives. - if FS.filename f == f - then do - ihaskellPath <- which "IHaskell" - case ihaskellPath of - Nothing -> error "IHaskell not on $PATH and not referenced relative to directory." - Just path -> return $ FS.encodeString path - else do - -- If it's actually a relative path, make it absolute. - cd <- liftIO getCurrentDirectory - return $ FS.encodeString $ FS.decodeString cd FS. f diff --git a/IHaskell/Message/Parser.hs b/IHaskell/Message/Parser.hs deleted file mode 100644 --- a/IHaskell/Message/Parser.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} --- | Description : Parsing messages received from IPython --- --- This module is responsible for converting from low-level ByteStrings --- obtained from the 0MQ sockets into Messages. The only exposed function is --- `parseMessage`, which should only be used in the low-level 0MQ interface. -module IHaskell.Message.Parser (parseMessage) where - -import ClassyPrelude -import Data.Aeson ((.:), decode, Result(..), Object) -import Data.Aeson.Types (parse) - -import qualified Data.ByteString.Lazy as Lazy - -import IHaskell.Types - ------ External interface ----- - --- | Parse a message from its ByteString components into a Message. -parseMessage :: [ByteString] -- ^ The list of identifiers sent with the message. - -> ByteString -- ^ The header data. - -> ByteString -- ^ The parent header, which is just "{}" if there is no header. - -> ByteString -- ^ The metadata map, also "{}" for an empty map. - -> ByteString -- ^ The message content. - -> Message -- ^ A parsed message. -parseMessage idents headerData parentHeader metadata content = - let header = parseHeader idents headerData parentHeader metadata - messageType = msgType header - messageWithoutHeader = parser messageType $ Lazy.fromStrict content in - messageWithoutHeader { header = header } - ------ Module internals ----- - --- | Parse a header from its ByteString components into a MessageHeader. -parseHeader :: [ByteString] -- ^ The list of identifiers. - -> ByteString -- ^ The header data. - -> ByteString -- ^ The parent header, or "{}" for Nothing. - -> ByteString -- ^ The metadata, or "{}" for an empty map. - -> MessageHeader -- The resulting message header. -parseHeader idents headerData parentHeader metadata = MessageHeader { - identifiers = idents, - parentHeader = parentResult, - metadata = metadataMap, - messageId = messageUUID, - sessionId = sessionUUID, - username = username, - msgType = messageType - } where - -- Decode the header data and the parent header data into JSON objects. - -- If the parent header data is absent, just have Nothing instead. - Just result = decode $ Lazy.fromStrict headerData :: Maybe Object - parentResult = if parentHeader == "{}" - then Nothing - else Just $ parseHeader idents parentHeader "{}" metadata - - -- Get the basic fields from the header. - Success (messageType, username, messageUUID, sessionUUID) = flip parse result $ \obj -> do - messType <- obj .: "msg_type" - username <- obj .: "username" - message <- obj .: "msg_id" - session <- obj .: "session" - return (messType, username, message, session) - - -- Get metadata as a simple map. - Just metadataMap = decode $ Lazy.fromStrict metadata :: Maybe (Map ByteString ByteString) - -noHeader :: MessageHeader -noHeader = error "No header created" - -parser :: MessageType -- ^ The message type being parsed. - -> LByteString -> Message -- The parser that converts the body into a message. - -- This message should have an undefined - -- header. -parser KernelInfoRequestMessage = kernelInfoRequestParser -parser ExecuteRequestMessage = executeRequestParser -parser CompleteRequestMessage = completeRequestParser -parser ObjectInfoRequestMessage = objectInfoRequestParser -parser ShutdownRequestMessage = shutdownRequestParser -parser other = error $ "Unknown message type " ++ show other - --- | Parse a kernel info request. --- A kernel info request has no auxiliary information, so ignore the body. -kernelInfoRequestParser :: LByteString -> Message -kernelInfoRequestParser _ = KernelInfoRequest { header = noHeader } - --- | Parse an execute request. --- Fields used are: --- 1. "code": the code to execute. --- 2. "silent": whether to execute silently. --- 3. "store_history": whether to include this in history. --- 4. "allow_stdin": whether to allow reading from stdin for this code. -executeRequestParser :: LByteString -> Message -executeRequestParser content = - let parser obj = do - code <- obj .: "code" - silent <- obj .: "silent" - storeHistory <- obj .: "store_history" - allowStdin <- obj .: "allow_stdin" - - return (code, silent, storeHistory, allowStdin) - Just decoded = decode content - Success (code, silent, storeHistory, allowStdin) = parse parser decoded in - ExecuteRequest { - header = noHeader, - getCode = code, - getSilent = silent, - getAllowStdin = allowStdin, - getStoreHistory = storeHistory, - getUserVariables = [], - getUserExpressions = [] - } - -completeRequestParser :: LByteString -> Message -completeRequestParser content = parsed - where - Success parsed = flip parse decoded $ \ obj -> do - code <- obj .: "block" <|> return "" - codeLine <- obj .: "line" - pos <- obj .: "cursor_pos" - return $ CompleteRequest noHeader code codeLine pos - - Just decoded = decode content - -objectInfoRequestParser :: LByteString -> Message -objectInfoRequestParser content = parsed - where - Success parsed = flip parse decoded $ \obj -> do - oname <- obj .: "oname" - dlevel <- obj .: "detail_level" - return $ ObjectInfoRequest noHeader oname dlevel - - Just decoded = decode content - - -shutdownRequestParser :: LByteString -> Message -shutdownRequestParser content = parsed - where - Success parsed = flip parse decoded $ \ obj -> do - code <- obj .: "restart" - return $ ShutdownRequest noHeader code - - Just decoded = decode content diff --git a/IHaskell/Message/UUID.hs b/IHaskell/Message/UUID.hs deleted file mode 100644 --- a/IHaskell/Message/UUID.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} --- | Description : UUID generator and data structure --- --- Generate, parse, and pretty print UUIDs for use with IPython. -module IHaskell.Message.UUID ( - UUID, - random, randoms, - ) where - -import ClassyPrelude -import Control.Monad (mzero) -import Data.Aeson -import Data.UUID.V4 (nextRandom) - --- We use an internal string representation because for the purposes of --- IPython, it matters whether the letters are uppercase or lowercase and --- whether the dashes are present in the correct locations. For the --- purposes of new UUIDs, it does not matter, but IPython expects UUIDs --- passed to kernels to be returned unchanged, so we cannot actually parse --- them. - --- | A UUID (universally unique identifier). -data UUID = UUID String deriving Eq - -instance Show UUID where - show (UUID s) = s - --- | Generate a list of random UUIDs. -randoms :: Int -- ^ Number of UUIDs to generate. - -> IO [UUID] -randoms n = replicateM n random - --- | Generate a single random UUID. -random :: IO UUID -random = UUID <$> show <$> nextRandom - --- Allows reading and writing UUIDs as Strings in JSON. -instance FromJSON UUID where - parseJSON val@(String _) = UUID <$> parseJSON val - - -- UUIDs must be Strings. - parseJSON _ = mzero - -instance ToJSON UUID where - -- Extract the string from the UUID. - toJSON (UUID str) = String $ pack str diff --git a/IHaskell/Message/Writer.hs b/IHaskell/Message/Writer.hs deleted file mode 100644 --- a/IHaskell/Message/Writer.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} --- | Description : @ToJSON@ for Messages --- --- This module contains the @ToJSON@ instance for @Message@. -module IHaskell.Message.Writer ( - ToJSON(..) -) where - -import Prelude (read) -import ClassyPrelude -import Data.Aeson - -import Language.Haskell.TH -import Shelly hiding (trace) - -import IHaskell.Types - --- | Compute the GHC API version number using Template Haskell. -ghcVersionInts :: [Int] -ghcVersionInts = ints . map read . words . map dotToSpace $ version - where dotToSpace '.' = ' ' - dotToSpace x = x - - version :: String - version = $(runIO (unpack <$> shelly (run "ghc" ["--numeric-version"])) >>= stringE) - --- Convert message bodies into JSON. -instance ToJSON Message where - toJSON KernelInfoReply{} = object [ - "protocol_version" .= ints [4, 0], -- current protocol version, major and minor - "language_version" .= ghcVersionInts, - "language" .= string "haskell" - ] - - toJSON ExecuteReply{ status = status, executionCounter = counter} = object [ - "status" .= show status, - "execution_count" .= counter, - "payload" .= emptyList, - "user_variables" .= emptyMap, - "user_expressions" .= emptyMap - ] - toJSON PublishStatus{ executionState = executionState } = object [ - "execution_state" .= executionState - ] - toJSON PublishStream{ streamType = streamType, streamContent = content } = object [ - "data" .= content, - "name" .= streamType - ] - toJSON PublishDisplayData{ source = src, displayData = datas } = object [ - "source" .= src, - "metadata" .= object [], - "data" .= object (map displayDataToJson datas) - ] - - toJSON PublishOutput{ executionCount = execCount, reprText = reprText } = object [ - "data" .= object ["text/plain" .= reprText], - "execution_count" .= execCount, - "metadata" .= object [] - ] - toJSON PublishInput{ executionCount = execCount, inCode = code } = object [ - "execution_count" .= execCount, - "code" .= code - ] - toJSON (CompleteReply _ m mt t s) = object [ - "matches" .= m, - "matched_text" .= mt, - "text" .= t, - "status" .= if s then "ok" :: String else "error" - ] - toJSON o@ObjectInfoReply{} = object [ - "oname" .= objectName o, - "found" .= objectFound o, - "ismagic" .= False, - "isalias" .= False, - "type_name" .= objectTypeString o, - "docstring" .= objectDocString o - ] - - toJSON ShutdownReply{restartPending = restart} = object [ - "restart" .= restart - ] - - toJSON ClearOutput{wait = wait} = object [ - "wait" .= wait - ] - - - toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body - - --- | Print an execution state as "busy", "idle", or "starting". -instance ToJSON ExecutionState where - toJSON Busy = String "busy" - toJSON Idle = String "idle" - toJSON Starting = String "starting" - --- | Print a stream as "stdin" or "stdout" strings. -instance ToJSON StreamType where - toJSON Stdin = String "stdin" - toJSON Stdout = String "stdout" - --- | Convert a MIME type and value into a JSON dictionary pair. -displayDataToJson :: DisplayData -> (Text, Value) -displayDataToJson (Display mimeType dataStr) = pack (show mimeType) .= dataStr - ------ Constants ----- - -emptyMap :: Map String String -emptyMap = mempty - -emptyList :: [Int] -emptyList = [] - -ints :: [Int] -> [Int] -ints = id - -string :: String -> String -string = id diff --git a/IHaskell/Types.hs b/IHaskell/Types.hs deleted file mode 100644 --- a/IHaskell/Types.hs +++ /dev/null @@ -1,315 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} --- | Description : All message type definitions. -module IHaskell.Types ( - Profile (..), - Message (..), - MessageHeader (..), - MessageType(..), - Username, - Metadata, - Port, - replyType, - ExecutionState (..), - StreamType(..), - MimeType(..), - DisplayData(..), - ExecuteReplyStatus(..), - InitInfo(..), - ) where - -import ClassyPrelude -import Data.Aeson -import IHaskell.Message.UUID -import Data.Serialize -import GHC.Generics (Generic) - - - --- | A TCP port. -type Port = Int - --- | A kernel profile, specifying how the kernel communicates. -data Profile = Profile { - ip :: String, -- ^ The IP on which to listen. - transport :: String, -- ^ The transport mechanism. - stdinPort :: Port, -- ^ The stdin channel port. - controlPort :: Port, -- ^ The control channel port. - hbPort :: Port, -- ^ The heartbeat channel port. - shellPort :: Port, -- ^ The shell command port. - iopubPort :: Port, -- ^ The Iopub port. - key :: ByteString -- ^ The HMAC encryption key. - } deriving Show - --- Convert the kernel profile to and from JSON. -instance FromJSON Profile where - parseJSON (Object v) = - Profile <$> v .: "ip" - <*> v .: "transport" - <*> v .: "stdin_port" - <*> v .: "control_port" - <*> v .: "hb_port" - <*> v .: "shell_port" - <*> v .: "iopub_port" - <*> v .: "key" - parseJSON _ = fail "Expecting JSON object." - -instance ToJSON Profile where - toJSON profile = object [ - "ip" .= ip profile, - "transport" .= transport profile, - "stdin_port" .= stdinPort profile, - "control_port".= controlPort profile, - "hb_port" .= hbPort profile, - "shell_port" .= shellPort profile, - "iopub_port" .= iopubPort profile, - "key" .= key profile - ] - --- | Initialization information for the kernel. -data InitInfo = InitInfo { - extensions :: [String], -- ^ Extensions to enable at start. - initCells :: [String] -- ^ Code blocks to run before start. - } - deriving (Show, Read) - --- | A message header with some metadata. -data MessageHeader = MessageHeader { - identifiers :: [ByteString], -- ^ The identifiers sent with the message. - parentHeader :: Maybe MessageHeader, -- ^ The parent header, if present. - metadata :: Metadata, -- ^ A dict of metadata. - messageId :: UUID, -- ^ A unique message UUID. - sessionId :: UUID, -- ^ A unique session UUID. - username :: Username, -- ^ The user who sent this message. - msgType :: MessageType -- ^ The message type. - } deriving Show - --- Convert a message header into the JSON field for the header. --- This field does not actually have all the record fields. -instance ToJSON MessageHeader where - toJSON header = object [ - "msg_id" .= messageId header, - "session" .= sessionId header, - "username" .= username header, - "msg_type" .= show (msgType header) - ] - --- | A username for the source of a message. -type Username = ByteString - --- | A metadata dictionary. -type Metadata = Map ByteString ByteString - --- | The type of a message, corresponding to IPython message types. -data MessageType = KernelInfoReplyMessage - | KernelInfoRequestMessage - | ExecuteReplyMessage - | ExecuteRequestMessage - | StatusMessage - | StreamMessage - | DisplayDataMessage - | OutputMessage - | InputMessage - | CompleteRequestMessage - | CompleteReplyMessage - | ObjectInfoRequestMessage - | ObjectInfoReplyMessage - | ShutdownRequestMessage - | ShutdownReplyMessage - | ClearOutputMessage - -instance Show MessageType where - show KernelInfoReplyMessage = "kernel_info_reply" - show KernelInfoRequestMessage = "kernel_info_request" - show ExecuteReplyMessage = "execute_reply" - show ExecuteRequestMessage = "execute_request" - show StatusMessage = "status" - show StreamMessage = "stream" - show DisplayDataMessage = "display_data" - show OutputMessage = "pyout" - show InputMessage = "pyin" - show CompleteRequestMessage = "complete_request" - show CompleteReplyMessage = "complete_reply" - show ObjectInfoRequestMessage = "object_info_request" - show ObjectInfoReplyMessage = "object_info_reply" - show ShutdownRequestMessage = "shutdown_request" - show ShutdownReplyMessage = "shutdown_reply" - show ClearOutputMessage = "clear_output" - -instance FromJSON MessageType where - parseJSON (String s) = case s of - "kernel_info_reply" -> return KernelInfoReplyMessage - "kernel_info_request" -> return KernelInfoRequestMessage - "execute_reply" -> return ExecuteReplyMessage - "execute_request" -> return ExecuteRequestMessage - "status" -> return StatusMessage - "stream" -> return StreamMessage - "display_data" -> return DisplayDataMessage - "pyout" -> return OutputMessage - "pyin" -> return InputMessage - "complete_request" -> return CompleteRequestMessage - "complete_reply" -> return CompleteReplyMessage - "object_info_request" -> return ObjectInfoRequestMessage - "object_info_reply" -> return ObjectInfoReplyMessage - "shutdown_request" -> return ShutdownRequestMessage - "shutdown_reply" -> return ShutdownReplyMessage - "clear_output" -> return ClearOutputMessage - - _ -> fail ("Unknown message type: " ++ show s) - parseJSON _ = fail "Must be a string." - - --- | A message used to communicate with the IPython frontend. -data Message - -- | A request from a frontend for information about the kernel. - = KernelInfoRequest { header :: MessageHeader } - -- | A response to a KernelInfoRequest. - | KernelInfoReply { header :: MessageHeader } - - -- | A request from a frontend to execute some code. - | ExecuteRequest { - header :: MessageHeader, - getCode :: ByteString, -- ^ The code string. - getSilent :: Bool, -- ^ Whether this should be silently executed. - getStoreHistory :: Bool, -- ^ Whether to store this in history. - getAllowStdin :: Bool, -- ^ Whether this code can use stdin. - - getUserVariables :: [ByteString], -- ^ Unused. - getUserExpressions :: [ByteString] -- ^ Unused. - } - - -- | A reply to an execute request. - | ExecuteReply { - header :: MessageHeader, - status :: ExecuteReplyStatus, -- ^ The status of the output. - executionCounter :: Int -- ^ The execution count, i.e. which output this is. - } - - | PublishStatus { - header :: MessageHeader, - executionState :: ExecutionState -- ^ The execution state of the kernel. - } - - | PublishStream { - header :: MessageHeader, - streamType :: StreamType, -- ^ Which stream to publish to. - streamContent :: String -- ^ What to publish. - } - - | PublishDisplayData { - header :: MessageHeader, - source :: String, -- ^ The name of the data source. - displayData :: [DisplayData] -- ^ A list of data representations. - } - - | PublishOutput { - header :: MessageHeader, - reprText :: String, -- ^ Printed output text. - executionCount :: Int -- ^ Which output this is for. - } - - | PublishInput { - header :: MessageHeader, - inCode :: String, -- ^ Submitted input code. - executionCount :: Int -- ^ Which input this is. - } - - | CompleteRequest { - header :: MessageHeader, - getCode :: ByteString, {- ^ - The entire block of text where the line is. This may be useful in the - case of multiline completions where more context may be needed. Note: if - in practice this field proves unnecessary, remove it to lighten the - messages. json field @block@ -} - getCodeLine :: ByteString, -- ^ just the line with the cursor. json field @line@ - getCursorPos :: Int -- ^ position of the cursor (index into the line?). json field @cursor_pos@ - - } - - | CompleteReply { - header :: MessageHeader, - completionMatches :: [ByteString], - completionMatchedText :: ByteString, - completionText :: ByteString, - completionStatus :: Bool - } - - | ObjectInfoRequest { - header :: MessageHeader, - objectName :: ByteString, -- ^ Name of object being searched for. - detailLevel :: Int -- ^ Level of detail desired (defaults to 0). - -- 0 is equivalent to foo?, 1 is equivalent - -- to foo??. - } - - | ObjectInfoReply { - header :: MessageHeader, - objectName :: ByteString, -- ^ Name of object which was searched for. - objectFound :: Bool, -- ^ Whether the object was found. - objectTypeString :: ByteString, -- ^ Object type. - objectDocString :: ByteString - } - - | ShutdownRequest { - header :: MessageHeader, - restartPending :: Bool -- ^ Whether this shutdown precedes a restart. - } - | ShutdownReply { - header :: MessageHeader, - restartPending :: Bool -- ^ Whether this shutdown precedes a restart. - } - - | ClearOutput { - header :: MessageHeader, - wait :: Bool -- ^ Whether to wait to redraw until there is more output. - } - - deriving Show - --- | Possible statuses in the execution reply messages. -data ExecuteReplyStatus = Ok | Err | Abort - -instance Show ExecuteReplyStatus where - show Ok = "ok" - show Err = "error" - show Abort = "abort" - --- | The execution state of the kernel. -data ExecutionState = Busy | Idle | Starting deriving Show - --- | Data for display: a string with associated MIME type. -data DisplayData = Display MimeType String deriving (Show, Typeable, Generic) - --- Allow DisplayData serialization -instance Serialize DisplayData -instance Serialize MimeType - --- | Possible MIME types for the display data. -data MimeType = PlainText - | MimeHtml - | MimePng - | MimeJpg - | MimeSvg - | MimeLatex - deriving (Eq, Typeable, Generic) - - -instance Show MimeType where - show PlainText = "text/plain" - show MimeHtml = "text/html" - show MimePng = "image/png" - show MimeJpg = "image/jpeg" - show MimeSvg = "image/svg+xml" - show MimeLatex = "text/latex" - --- | Input and output streams. -data StreamType = Stdin | Stdout deriving Show - --- | Get the reply message type for a request message type. -replyType :: MessageType -> MessageType -replyType KernelInfoRequestMessage = KernelInfoReplyMessage -replyType ExecuteRequestMessage = ExecuteReplyMessage -replyType CompleteRequestMessage = CompleteReplyMessage -replyType ObjectInfoRequestMessage = ObjectInfoReplyMessage -replyType ShutdownRequestMessage = ShutdownReplyMessage -replyType messageType = error $ "No reply for message type " ++ show messageType diff --git a/IHaskell/ZeroMQ.hs b/IHaskell/ZeroMQ.hs deleted file mode 100644 --- a/IHaskell/ZeroMQ.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} --- | Description : Low-level ZeroMQ communication wrapper. --- --- The "ZeroMQ" module abstracts away the low-level 0MQ based interface with IPython, --- replacing it instead with a Haskell Channel based interface. The `serveProfile` function --- takes a IPython profile specification and returns the channel interface to use. -module IHaskell.ZeroMQ ( - ZeroMQInterface (..), - serveProfile - ) where - -import ClassyPrelude hiding (stdin) -import Control.Concurrent -import System.ZMQ3 hiding (stdin) -import Data.Aeson (encode) - -import qualified Data.ByteString.Lazy as ByteString - -import IHaskell.Types -import IHaskell.Message.Parser -import IHaskell.Message.Writer - --- | The channel interface to the ZeroMQ sockets. All communication is done via --- Messages, which are encoded and decoded into a lower level form before being --- transmitted to IPython. These channels should functionally serve as --- high-level sockets which speak Messages instead of ByteStrings. -data ZeroMQInterface = Channels { - shellRequestChannel :: Chan Message, -- ^ A channel populated with requests from the frontend. - shellReplyChannel :: Chan Message, -- ^ Writing to this channel causes a reply to be sent to the frontend. - controlRequestChannel :: Chan Message, -- ^ This channel is a duplicate of the shell request channel, - -- ^ though using a different backend socket. - controlReplyChannel :: Chan Message, -- ^ This channel is a duplicate of the shell reply channel, - -- ^ though using a different backend socket. - iopubChannel :: Chan Message -- ^ Writing to this channel sends an iopub message to the frontend. - } - --- | Start responding on all ZeroMQ channels used to communicate with IPython --- | via the provided profile. Return a set of channels which can be used to --- | communicate with IPython in a more structured manner. -serveProfile :: Profile -- ^ The profile specifying which ports and transport mechanisms to use. - -> IO ZeroMQInterface -- ^ The Message-channel based interface to the sockets. -serveProfile profile = do - -- Create all channels which will be used for higher level communication. - shellReqChan <- newChan - shellRepChan <- newChan - controlReqChan <- dupChan shellReqChan - controlRepChan <- dupChan shellRepChan - iopubChan <- newChan - let channels = Channels shellReqChan shellRepChan controlReqChan controlRepChan iopubChan - - -- Create the context in a separate thread that never finishes. If - -- withContext or withSocket complete, the context or socket become invalid. - forkIO $ withContext $ \context -> do - -- Serve on all sockets. - forkIO $ serveSocket context Rep (hbPort profile) $ heartbeat channels - forkIO $ serveSocket context Router (controlPort profile) $ control channels - forkIO $ serveSocket context Router (shellPort profile) $ shell channels - forkIO $ serveSocket context Router (stdinPort profile) $ stdin channels - - -- The context is reference counted in this thread only. Thus, the last - -- serveSocket cannot be asynchronous, because otherwise context would - -- be garbage collectable - since it would only be used in other - -- threads. Thus, keep the last serveSocket in this thread. - serveSocket context Pub (iopubPort profile) $ iopub channels - - return channels - --- | Serve on a given socket in a separate thread. Bind the socket in the --- | given context and then loop the provided action, which should listen --- | on the socket and respond to any events. -serveSocket :: SocketType a => Context -> a -> Port -> (Socket a -> IO b) -> IO () -serveSocket context socketType port action = void $ - withSocket context socketType $ \socket -> do - bind socket $ unpack $ "tcp://127.0.0.1:" ++ show port - forever $ action socket - --- | Listener on the heartbeat port. Echoes back any data it was sent. -heartbeat :: ZeroMQInterface -> Socket Rep -> IO () -heartbeat _ socket = do - -- Read some data. - request <- receive socket - - -- Send it back. - send socket [] request - --- | Listener on the shell port. Reads messages and writes them to --- | the shell request channel. For each message, reads a response from the --- | shell reply channel of the interface and sends it back to the frontend. -shell :: ZeroMQInterface -> Socket Router -> IO () -shell channels socket = do - -- Receive a message and write it to the interface channel. - receiveMessage socket >>= writeChan requestChannel - - -- Read the reply from the interface channel and send it. - readChan replyChannel >>= sendMessage socket - - where - requestChannel = shellRequestChannel channels - replyChannel = shellReplyChannel channels - --- | Listener on the shell port. Reads messages and writes them to --- | the shell request channel. For each message, reads a response from the --- | shell reply channel of the interface and sends it back to the frontend. -control :: ZeroMQInterface -> Socket Router -> IO () -control channels socket = do - -- Receive a message and write it to the interface channel. - receiveMessage socket >>= writeChan requestChannel - - -- Read the reply from the interface channel and send it. - readChan replyChannel >>= sendMessage socket - - where - requestChannel = controlRequestChannel channels - replyChannel = controlReplyChannel channels - --- | Send messages via the iopub channel. --- | This reads messages from the ZeroMQ iopub interface channel --- | and then writes the messages to the socket. -iopub :: ZeroMQInterface -> Socket Pub -> IO () -iopub channels socket = - readChan (iopubChannel channels) >>= sendMessage socket - -stdin :: ZeroMQInterface -> Socket Router -> IO () -stdin _ socket = do - void $ receive socket - return () - --- | Receive and parse a message from a socket. -receiveMessage :: Receiver a => Socket a -> IO Message -receiveMessage socket = do - -- Read all identifiers until the identifier/message delimiter. - idents <- readUntil "" - - -- Ignore the signature for now. - void next - - headerData <- next - parentHeader <- next - metadata <- next - content <- next - - let message = parseMessage idents headerData parentHeader metadata content - return message - - where - -- Receive the next piece of data from the socket. - next = receive socket - - -- Read data from the socket until we hit an ending string. - -- Return all data as a list, which does not include the ending string. - readUntil str = do - line <- next - if line /= str - then do - remaining <- readUntil str - return $ line : remaining - else return [] - --- | Encode a message in the IPython ZeroMQ communication protocol --- | and send it through the provided socket. -sendMessage :: Sender a => Socket a -> Message -> IO () -sendMessage socket message = do - let head = header message - parentHeaderStr = maybe "{}" encodeStrict $ parentHeader head - idents = identifiers head - metadata = "{}" - content = encodeStrict message - headStr = encodeStrict head - - -- Send all pieces of the message. - mapM_ sendPiece idents - sendPiece "" - sendPiece "" - sendPiece headStr - sendPiece parentHeaderStr - sendPiece metadata - - -- Conclude transmission with content. - sendLast content - - where - sendPiece = send socket [SendMore] - sendLast = send socket [] - - -- Encode to a strict bytestring. - encodeStrict :: ToJSON a => a -> ByteString - encodeStrict = ByteString.toStrict . encode diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,352 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | 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) -import Control.Concurrent.Chan -import Control.Concurrent (threadDelay) -import Data.Aeson -import Text.Printf -import System.Exit (exitSuccess) -import System.Directory -import System.Console.CmdArgs.Explicit hiding (complete) - -import qualified Data.Map as Map - -import IHaskell.Types -import IHaskell.ZeroMQ -import qualified IHaskell.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 GHC hiding (extensions) -import Outputable (showSDoc, ppr) - --- All state stored in the kernel between executions. -data KernelState = KernelState - { getExecutionCounter :: Int - } - --- Command line arguments to IHaskell. A set of aruments is annotated with --- the mode being invoked. -data Args = Args IHaskellMode [Argument] - -data Argument - = ServeFrom String -- ^ Which directory to serve notebooks from. - | Extension String -- ^ An extension to load at startup. - | ConfFile String -- ^ A file with commands to load at startup. - | Help -- ^ Display help text. - deriving (Eq, Show) - --- Which mode IHaskell is being invoked in. --- `None` means no mode was specified. -data IHaskellMode - = None - | Notebook - | Console - | UpdateIPython - | Kernel (Maybe String) - deriving (Eq, Show) - -main :: IO () -main = do - stringArgs <- map unpack <$> getArgs - case process ihaskellArgs stringArgs of - Left errmsg -> putStrLn $ pack errmsg - Right args -> - ihaskell args - -universalFlags :: [Flag Args] -universalFlags = [ - flagReq ["extension","e", "X"] (store Extension) "" "Extension to enable at start.", - flagReq ["conf","c"] (store ConfFile) "" "File with commands to execute at start.", - flagHelpSimple (add Help) - ] - where - add flag (Args mode flags) = Args mode $ flag : flags - -store :: (String -> Argument) -> String -> Args -> Either String Args -store constructor str (Args mode prev) = Right $ Args mode $ constructor str : prev - -notebook :: Mode Args -notebook = mode "notebook" (Args Notebook []) "Browser-based notebook interface." noArgs $ - flagReq ["serve","s"] (store ServeFrom) "" "Directory to serve notebooks from.": - universalFlags - -console :: Mode Args -console = mode "console" (Args Console []) "Console-based interactive repl." noArgs universalFlags - -kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg [] - where - kernelArg = flagArg update "" - update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags - -update :: Mode Args -update = mode "update" (Args UpdateIPython []) "Update IPython frontends." noArgs [] - -ihaskellArgs :: Mode Args -ihaskellArgs = (modeEmpty $ Args None []) { modeGroupModes = toGroup [console, notebook, update, kernel] } - -noArgs = flagArg unexpected "" - where - unexpected a = error $ "Unexpected argument: " ++ a - -ihaskell :: Args -> IO () --- If no mode is specified, print help text. -ihaskell (Args None _) = - print $ helpText [] HelpFormatAll ihaskellArgs - --- Update IPython: remove then reinstall. --- This is in case cabal updates IHaskell but the corresponding IPython --- isn't updated. This is hard to detect since versions of IPython might --- not change! -ihaskell (Args UpdateIPython _) = do - removeIPython - installIPython - putStrLn "IPython updated." - -ihaskell (Args Console flags) = showingHelp Console flags $ do - installed <- ipythonInstalled - unless installed installIPython - - flags <- addDefaultConfFile flags - info <- initInfo flags - runConsole info - -ihaskell (Args Notebook flags) = showingHelp Notebook flags $ do - installed <- ipythonInstalled - unless installed installIPython - - let server = case mapMaybe serveDir flags of - [] -> Nothing - xs -> Just $ last xs - - flags <- addDefaultConfFile flags - info <- initInfo flags - runNotebook info server - where - serveDir (ServeFrom dir) = Just dir - serveDir _ = Nothing - -ihaskell (Args (Kernel (Just filename)) _) = do - initInfo <- readInitInfo - runKernel filename initInfo - --- | Add a conf file to the arguments if none exists. -addDefaultConfFile :: [Argument] -> IO [Argument] -addDefaultConfFile flags = do - def <- defaultConfFile - case (find isConfFile flags, def) of - (Nothing, Just file) -> return $ ConfFile file : flags - _ -> return flags - where - isConfFile (ConfFile _) = True - isConfFile _ = False - -showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO () -showingHelp mode flags act = - case find (==Help) flags of - Just _ -> - print $ helpText [] HelpFormatAll $ chooseMode mode - Nothing -> - act - where - chooseMode Console = console - chooseMode Notebook = notebook - chooseMode (Kernel _) = kernel - chooseMode UpdateIPython = update - --- | Parse initialization information from the flags. -initInfo :: [Argument] -> IO InitInfo -initInfo [] = return InitInfo { extensions = [], initCells = []} -initInfo (flag:flags) = do - info <- initInfo flags - case flag of - Extension ext -> return info { extensions = ext:extensions info } - ConfFile filename -> do - cell <- readFile (fpFromText $ pack filename) - return info { initCells = cell:initCells info } - --- | Run the IHaskell language kernel. -runKernel :: String -- ^ Filename of profile JSON file. - -> InitInfo -- ^ Initialization information from the invocation. - -> IO () -runKernel profileSrc initInfo = do - -- Switch to a temporary directory so that any files we create aren't - -- visible. On Unix, this is usually /tmp. If there is no temporary - -- directory available, just stay in the current one and ignore the - -- raised exception. - try (getTemporaryDirectory >>= setCurrentDirectory) :: IO (Either SomeException ()) - - -- Parse the profile file. - Just profile <- liftM decode . readFile . fpFromText $ pack profileSrc - - -- Serve on all sockets and ports defined in the profile. - interface <- serveProfile profile - - state <- initialKernelState - - -- Receive and reply to all messages on the shell socket. - interpret $ do - -- Initialize the context by evaluating everything we got from the - -- command line flags. This includes enabling some extensions and also - -- running some code. - let extLines = map (":extension " ++) $ extensions initInfo - noPublish _ _ = return () - zero = 0 -- To please hlint - evaluator line = evaluate zero line noPublish - mapM_ evaluator extLines - mapM_ evaluator $ initCells initInfo - - forever $ do - -- Read the request from the request channel. - request <- liftIO $ readChan $ shellRequestChannel interface - - -- Create a header for the reply. - replyHeader <- createReplyHeader (header request) - - -- Create the reply, possibly modifying kernel state. - oldState <- liftIO $ takeMVar state - (newState, reply) <- replyTo interface request replyHeader oldState - liftIO $ putMVar state newState - - -- Write the reply to the reply channel. - liftIO $ writeChan (shellReplyChannel interface) reply - --- Initial kernel state. -initialKernelState :: IO (MVar KernelState) -initialKernelState = - newMVar KernelState { - getExecutionCounter = 1 - } - --- | Duplicate a message header, giving it a new UUID and message type. -dupHeader :: MessageHeader -> MessageType -> IO MessageHeader -dupHeader header messageType = do - uuid <- liftIO UUID.random - - return header { messageId = uuid, msgType = messageType } - --- | Create a new message header, given a parent message header. -createReplyHeader :: MessageHeader -> Interpreter MessageHeader -createReplyHeader parent = do - -- Generate a new message UUID. - newMessageId <- liftIO UUID.random - - return MessageHeader { - identifiers = identifiers parent, - parentHeader = Just parent, - metadata = Map.fromList [], - messageId = newMessageId, - sessionId = sessionId parent, - username = username parent, - msgType = replyType $ msgType parent - } - --- | Compute a reply to a message. -replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message) - --- Reply to kernel info requests with a kernel info reply. No computation --- needs to be done, as a kernel info reply is a static object (all info is --- hard coded into the representation of that message type). -replyTo _ KernelInfoRequest{} replyHeader state = return (state, KernelInfoReply { header = replyHeader }) - --- Reply to a shutdown request by exiting the main thread. --- Before shutdown, reply to the request to let the frontend know shutdown --- is happening. -replyTo interface ShutdownRequest{restartPending = restartPending} replyHeader _ = liftIO $ do - writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending - exitSuccess - --- Reply to an execution request. The reply itself does not require --- computation, but this causes messages to be sent to the IOPub socket --- with the output of the code in the execution request. -replyTo interface ExecuteRequest{ getCode = code } replyHeader state = do - let execCount = getExecutionCounter state - -- Convenience function to send a message to the IOPub socket. - send msg = liftIO $ writeChan (iopubChannel interface) msg - - -- Notify the frontend that the kernel is busy computing. - -- All the headers are copies of the reply header with a different - -- message type, because this preserves the session ID, parent header, - -- and other important information. - busyHeader <- liftIO $ dupHeader replyHeader StatusMessage - send $ PublishStatus busyHeader Busy - - -- Construct a function for publishing output as this is going. - -- This function accepts a boolean indicating whether this is the final - -- output and the thing to display. Store the final outputs in a list so - -- that when we receive an updated non-final output, we can clear the - -- entire output and re-display with the updated output. - displayed <- liftIO $ newMVar [] - updateNeeded <- liftIO $ newMVar False - let clearOutput = do - header <- dupHeader replyHeader ClearOutputMessage - send $ ClearOutput header True - - sendOutput outs = do - header <- dupHeader replyHeader DisplayDataMessage - send $ PublishDisplayData header "haskell" outs - - publish :: Bool -> [DisplayData] -> IO () - publish final outputs = do - -- If necessary, clear all previous output and redraw. - clear <- readMVar updateNeeded - when clear $ do - clearOutput - disps <- readMVar displayed - mapM_ sendOutput $ reverse disps - - -- Draw this message. - sendOutput outputs - - -- If this is the final message, add it to the list of completed - -- messages. If it isn't, make sure we clear it later by marking - -- update needed as true. - modifyMVar_ updateNeeded (const $ return $ not final) - when final $ - modifyMVar_ displayed (return . (outputs:)) - - -- Run code and publish to the frontend as we go. - evaluate execCount (Chars.unpack code) publish - - -- Notify the frontend that we're done computing. - idleHeader <- liftIO $ dupHeader replyHeader StatusMessage - send $ PublishStatus idleHeader Idle - - -- Increment the execution counter in the kernel state. - let newState = state { getExecutionCounter = execCount + 1 } - return (newState, ExecuteReply { - header = replyHeader, - executionCounter = execCount, - status = Ok - }) - - -replyTo _ req@CompleteRequest{} replyHeader state = do - (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) - --- | 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) - - - 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.2.0.5 +version: 0.3.0.0 -- A short (one-line) description of the package. synopsis: A Haskell backend kernel for the IPython project. @@ -40,130 +40,171 @@ build-type: Simple -- Constraint on the version of Cabal needed to build this package. -cabal-version: >=1.8 +cabal-version: >=1.16 data-files: profile/profile.tar library - build-depends: base ==4.6.*, - cmdargs >= 0.10, - tar, - ghc-parser, - unix >= 2.6, - hspec, - zeromq3-haskell >=0.5, - aeson >=0.6, - MissingH >=1.2, - classy-prelude >=0.6, - bytestring >=0.10, - uuid >=1.2.6, - containers >=0.5, - ghc ==7.6.*, - ghc-paths ==0.1.*, - random >=1.0, - split >= 0.2, - utf8-string, - strict >=0.3, - shelly >=1.3, - system-argv0, - directory, - here, - system-filepath, - cereal ==0.3.*, - text >=0.11, - mtl >= 2.1, - template-haskell - exposed-modules: IHaskell.Display, - Paths_ihaskell, - IHaskell.Types, - IHaskell.Message.UUID + hs-source-dirs: src + default-language: Haskell2010 + build-depends: + base ==4.6.*, + aeson >=0.6, + base64-bytestring >=1.0, + bytestring >=0.10, + cereal ==0.3.*, + classy-prelude >=0.7, + cmdargs >=0.10, + containers >=0.5, + directory -any, + filepath -any, + ghc ==7.6.*, + ghc-parser -any, + ghc-paths ==0.1.*, + haskeline -any, + here -any, + hlint -any, + hspec -any, + HTTP -any, + HUnit -any, + ipython-kernel -any, + MissingH >=1.2, + mtl >=2.1, + parsec -any, + process >=1.1, + random >=1.0, + shelly >=1.3, + split >= 0.2, + strict >=0.3, + system-argv0 -any, + system-filepath -any, + tar -any, + transformers -any, + unix >= 2.6, + utf8-string -any + exposed-modules: IHaskell.Display + IHaskell.Eval.Completion + IHaskell.Eval.Evaluate + IHaskell.Eval.Info + IHaskell.Eval.Lint + IHaskell.Eval.Parser + IHaskell.Eval.Hoogle + IHaskell.Eval.ParseShell + IHaskell.Eval.Util + IHaskell.IPython + IHaskell.Flags + IHaskell.Types + Paths_ihaskell + executable IHaskell -- .hs or .lhs file containing the Main module. + hs-source-dirs: src main-is: Main.hs build-tools: happy, cpphs -- Modules included in this executable, other than Main. other-modules: + IHaskell.Eval.Lint IHaskell.Eval.Completion IHaskell.Eval.Info IHaskell.Eval.Evaluate IHaskell.Eval.Parser + IHaskell.Eval.Hoogle + IHaskell.Eval.ParseShell + IHaskell.Eval.Util IHaskell.IPython - IHaskell.Message.Parser - IHaskell.Message.UUID - IHaskell.Message.Writer + IHaskell.Flags IHaskell.Types - IHaskell.ZeroMQ IHaskell.Display - IHaskell.Config - extensions: DoAndIfThenElse + default-extensions: DoAndIfThenElse -- Other library packages from which modules are imported. - build-depends: base ==4.6.*, - cmdargs >= 0.10, - tar, - ghc-parser, - unix >= 2.6, - hspec, - zeromq3-haskell >=0.5, - aeson >=0.6, - MissingH >=1.2, - classy-prelude >=0.6, - bytestring >=0.10, - uuid >=1.2.6, - containers >=0.5, - ghc ==7.6.*, - ghc-paths ==0.1.*, - random >=1.0, - split >= 0.2, - utf8-string, - strict >=0.3, - shelly >=1.3, - system-argv0, - directory, - here, - system-filepath, - cereal ==0.3.*, - text >=0.11, - mtl >= 2.1, - template-haskell + default-language: Haskell2010 + build-depends: + base ==4.6.*, + aeson >=0.6, + base64-bytestring >=1.0, + bytestring >=0.10, + cereal ==0.3.*, + classy-prelude >=0.7, + cmdargs >=0.10, + containers >=0.5, + directory -any, + filepath -any, + ghc ==7.6.*, + ghc-parser -any, + ghc-paths ==0.1.*, + haskeline -any, + here -any, + hlint -any, + hspec -any, + HTTP -any, + HUnit -any, + ipython-kernel -any, + MissingH >=1.2, + mtl >=2.1, + parsec -any, + process >=1.1, + random >=1.0, + shelly >=1.3, + split >= 0.2, + strict >=0.3, + system-argv0 -any, + system-filepath -any, + tar -any, + transformers -any, + unix >= 2.6, + utf8-string -any Test-Suite hspec + hs-source-dirs: src Type: exitcode-stdio-1.0 Ghc-Options: -threaded Main-Is: Hspec.hs - build-depends: base ==4.6.*, - cmdargs >= 0.10, - tar, - ghc-parser, - unix >= 2.6, - hspec, - zeromq3-haskell >=0.5, - aeson >=0.6, - MissingH >=1.2, - classy-prelude >=0.6, - bytestring >=0.10, - uuid >=1.2.6, - containers >=0.5, - ghc ==7.6.*, - ghc-paths ==0.1.*, - random >=1.0, - split >= 0.2, - utf8-string, - strict >=0.3, - shelly >=1.3, - system-argv0, - directory, - here, - system-filepath, - cereal ==0.3.*, - text >=0.11, - mtl >= 2.1, - template-haskell + default-language: Haskell2010 + build-depends: + base ==4.6.*, + aeson >=0.6, + base64-bytestring >=1.0, + bytestring >=0.10, + cereal ==0.3.*, + classy-prelude >=0.7, + cmdargs >=0.10, + containers >=0.5, + directory -any, + filepath -any, + ghc ==7.6.*, + ghc-parser -any, + ghc-paths ==0.1.*, + haskeline -any, + here -any, + hlint -any, + hspec -any, + HTTP -any, + HUnit -any, + ipython-kernel -any, + MissingH >=1.2, + mtl >=2.1, + parsec -any, + process >=1.1, + random >=1.0, + shelly >=1.3, + split >= 0.2, + strict >=0.3, + system-argv0 -any, + system-filepath -any, + tar -any, + transformers -any, + unix >= 2.6, + utf8-string -any + + extensions: DoAndIfThenElse + OverloadedStrings + ExtendedDefaultRules source-repository head type: git 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/Hspec.hs b/src/Hspec.hs new file mode 100644 --- /dev/null +++ b/src/Hspec.hs @@ -0,0 +1,570 @@ +{-# LANGUAGE QuasiQuotes, OverloadedStrings, ExtendedDefaultRules #-} +-- Keep all the language pragmas here so it can be compiled separately. +module Main where +import Prelude +import GHC +import GHC.Paths +import Data.IORef +import Control.Monad +import Control.Monad.Trans ( MonadIO, liftIO ) +import Data.List +import System.Directory +import Shelly (Sh, shelly, cmd, (), toTextIgnore, cd, withTmpDir, mkdir_p, + touchfile) +import qualified Shelly +import Filesystem.Path.CurrentOS (encodeString) +import System.SetEnv (setEnv) +import Data.String.Here +import Data.String.Utils (strip, replace) +import Data.Monoid + +import IHaskell.Eval.Parser +import IHaskell.Types +import IHaskell.IPython +import IHaskell.Eval.Evaluate as Eval hiding (liftIO) +import qualified IHaskell.Eval.Evaluate as Eval (liftIO) + +import IHaskell.Eval.Completion +import IHaskell.Eval.ParseShell + +import Debug.Trace + +import Test.Hspec +import Test.Hspec.HUnit +import Test.HUnit (assertBool, assertFailure) + +doGhc = runGhc (Just libdir) + +parses str = do + res <- doGhc $ parseString str + return $ map unloc res + +like parser desired = parser >>= (`shouldBe` desired) + +is string blockType = do + result <- doGhc $ parseString string + map unloc result `shouldBe` [blockType $ strip string] + +eval string = do + outputAccum <- newIORef [] + pagerAccum <- newIORef [] + let publish evalResult = case evalResult of + IntermediateResult {} -> return () + FinalResult outs page -> do + modifyIORef outputAccum (outs :) + modifyIORef pagerAccum (page :) + + getTemporaryDirectory >>= setCurrentDirectory + let state = defaultKernelState { getLintStatus = LintOff } + interpret False $ Eval.evaluate state string publish + out <- readIORef outputAccum + pagerOut <- readIORef pagerAccum + return (reverse out, unlines $ reverse pagerOut) + +evaluationComparing comparison string = do + let indent (' ':x) = 1 + indent x + indent _ = 0 + empty = null . strip + stringLines = filter (not . empty) $ lines string + minIndent = minimum (map indent stringLines) + newString = unlines $ map (drop minIndent) stringLines + eval newString >>= comparison + +becomes string expected = evaluationComparing comparison string + where + comparison :: ([Display], String) -> IO () + comparison (results, pageOut) = do + when (length results /= length expected) $ + expectationFailure $ "Expected result to have " ++ show (length expected) + ++ " results. Got " ++ show results + + forM_ (zip results expected) $ \(Display result, expected) -> + case extractPlain result of + "" -> expectationFailure $ "No plain-text output in " ++ show result ++ "\nExpected: " ++ expected + str -> str `shouldBe` expected + +pages string expected = evaluationComparing comparison string + where + comparison (results, pageOut) = + strip pageOut `shouldBe` strip (unlines expected) + +readCompletePrompt :: String -> (String, Int) +-- | @readCompletePrompt "xs*ys"@ return @(xs, i)@ where i is the location of +-- @'*'@ in the input string. +readCompletePrompt string = case elemIndex '*' string of + Nothing -> error "Expected cursor written as '*'." + Just idx -> (replace "*" "" string, idx) + +completes string expected = completionTarget newString cursorloc `shouldBe` expected + where (newString, cursorloc) = readCompletePrompt string + +completionEvent :: String -> Interpreter (String, [String]) +completionEvent string = do + complete newString cursorloc + where (newString, cursorloc) = case elemIndex '*' string of + Nothing -> error "Expected cursor written as '*'." + Just idx -> (replace "*" "" string, idx) + +completionEventInDirectory :: String -> IO (String, [String]) +completionEventInDirectory string + = withHsDirectory $ const $ completionEvent string + + +shouldHaveCompletionsInDirectory :: String -> [String] -> IO () +shouldHaveCompletionsInDirectory string expected + = do (matched, completions) <- completionEventInDirectory string + let existsInCompletion = (`elem` completions) + unmatched = filter (not . existsInCompletion) expected + expected `shouldBeAmong` completions + +completionHas string expected + = do (matched, completions) <- doGhc $ do initCompleter + completionEvent string + let existsInCompletion = (`elem` completions) + unmatched = filter (not . existsInCompletion) expected + expected `shouldBeAmong` completions + +initCompleter :: Interpreter () +initCompleter = do + flags <- getSessionDynFlags + setSessionDynFlags $ flags { hscTarget = HscInterpreted, ghcLink = LinkInMemory } + + -- Import modules. + imports <- mapM parseImportDecl ["import Prelude", + "import qualified Control.Monad", + "import qualified Data.List as List", + "import Data.Maybe as Maybe"] + setContext $ map IIDecl imports + +inDirectory :: [Shelly.FilePath] -- ^ directories relative to temporary directory + -> [Shelly.FilePath] -- ^ files relative to temporary directory + -> (Shelly.FilePath -> Interpreter a) + -> IO a +-- | Run an Interpreter action, but first make a temporary directory +-- with some files and folder and cd to it. +inDirectory dirs files action = shelly $ withTmpDir $ \dirPath -> + do cd dirPath + mapM_ mkdir_p dirs + mapM_ touchfile files + liftIO $ doGhc $ wrap (encodeString dirPath) (action dirPath) + where noPublish = const $ return () + cdEvent path = Eval.evaluate defaultKernelState (":! cd " ++ path) noPublish + wrap :: FilePath -> Interpreter a -> Interpreter a + wrap path action = + do initCompleter + pwd <- Eval.liftIO getCurrentDirectory + cdEvent path -- change to the temporary directory + out <- action -- run action + cdEvent pwd -- change back to the original directory + return out + +withHsDirectory :: (Shelly.FilePath -> Interpreter a) -> IO a +withHsDirectory = inDirectory ["" "dir", "dir" "dir1"] + ["" "file1.hs", "dir" "file2.hs", + "" "file1.lhs", "dir" "file2.lhs"] + +main :: IO () +main = hspec $ do + parserTests + evalTests + completionTests + +completionTests = do + parseShellTests + describe "Completion" $ do + it "correctly gets the completion identifier without dots" $ do + "hello*" `completes` ["hello"] + "hello aa*bb goodbye" `completes` ["aa"] + "hello aabb* goodbye" `completes` ["aabb"] + "aacc* goodbye" `completes` ["aacc"] + "hello *aabb goodbye" `completes` [] + "*aabb goodbye" `completes` [] + + it "correctly gets the completion identifier with dots" $ do + "hello test.aa*bb goodbye" `completes` ["test", "aa"] + "Test.*" `completes` ["Test", ""] + "Test.Thing*" `completes` ["Test", "Thing"] + "Test.Thing.*" `completes` ["Test", "Thing", ""] + "Test.Thing.*nope" `completes` ["Test", "Thing", ""] + + it "correctly gets the completion type" $ do + completionType "import Data." 12 ["Data", ""] `shouldBe` ModuleName "Data" "" + completionType "import Prel" 11 ["Prel"] `shouldBe` ModuleName "" "Prel" + completionType "import D.B.M" 12 ["D", "B", "M"] `shouldBe` ModuleName "D.B" "M" + completionType " import A." 10 ["A", ""] `shouldBe` ModuleName "A" "" + completionType "import a.x" 10 ["a", "x"] `shouldBe` Identifier "x" + completionType "A.x" 3 ["A", "x"] `shouldBe` Qualified "A" "x" + completionType "a.x" 3 ["a", "x"] `shouldBe` Identifier "x" + completionType "pri" 3 ["pri"] `shouldBe` Identifier "pri" + completionType ":load A" 7 ["A"] `shouldBe` HsFilePath ":load A" + "A" + completionType ":! cd " 6 [""] `shouldBe` FilePath ":! cd " "" + + + + it "properly completes identifiers" $ do + "pri*" `completionHas` ["print"] + "ma*" `completionHas` ["map"] + "hello ma*" `completionHas` ["map"] + "print $ catMa*" `completionHas` ["catMaybes"] + + it "properly completes qualified identifiers" $ do + "Control.Monad.liftM*" `completionHas` [ "Control.Monad.liftM" + , "Control.Monad.liftM2" + , "Control.Monad.liftM5"] + "print $ List.intercal*" `completionHas` ["List.intercalate"] + "print $ Data.Maybe.cat*" `completionHas` ["Data.Maybe.catMaybes"] + "print $ Maybe.catM*" `completionHas` ["Maybe.catMaybes"] + + it "properly completes imports" $ do + "import Data.*" `completionHas` ["Data.Maybe", "Data.List"] + "import Data.M*" `completionHas` ["Data.Maybe"] + "import Prel*" `completionHas` ["Prelude"] + + it "properly completes haskell file paths on :load directive" $ + let loading xs = ":load " ++ encodeString xs + paths xs = map encodeString xs + in do + loading ("dir" "file*") `shouldHaveCompletionsInDirectory` paths ["dir" "file2.hs", + "dir" "file2.lhs"] + loading ("" "file1*") `shouldHaveCompletionsInDirectory` paths ["" "file1.hs", + "" "file1.lhs"] + loading ("" "file1*") `shouldHaveCompletionsInDirectory` paths ["" "file1.hs", + "" "file1.lhs"] + loading ("" "./*") `shouldHaveCompletionsInDirectory` paths ["./" "dir/" + , "./" "file1.hs" + , "./" "file1.lhs"] + loading ("" "./*") `shouldHaveCompletionsInDirectory` paths ["./" "dir/" + , "./" "file1.hs" + , "./" "file1.lhs"] + + it "provides path completions on empty shell cmds " $ do + ":! cd *" `shouldHaveCompletionsInDirectory` (map encodeString ["" "dir/" + , "" "file1.hs" + , "" "file1.lhs"]) + + + it "correctly interprets ~ as the environment HOME variable" $ + let shouldHaveCompletions :: String -> [String] -> IO () + shouldHaveCompletions string expected = do + (matched, completions) + <- withHsDirectory $ \dirPath -> + do setHomeEvent dirPath + completionEvent string + let existsInCompletion = (`elem` completions) + unmatched = filter (not . existsInCompletion) expected + expected `shouldBeAmong` completions + + setHomeEvent path = liftIO $ setEnv "HOME" (encodeString path) + in do + ":! cd ~/*" `shouldHaveCompletions` ["~/dir/"] + ":! ~/*" `shouldHaveCompletions` ["~/dir/"] + ":load ~/*" `shouldHaveCompletions` ["~/dir/"] + ":l ~/*" `shouldHaveCompletions` ["~/dir/"] + + let shouldHaveMatchingText :: String -> String -> IO () + shouldHaveMatchingText string expected = do + matchText + <- withHsDirectory $ \dirPath -> + do setHomeEvent dirPath + (matchText, _) <- uncurry complete (readCompletePrompt string) + return matchText + matchText `shouldBe` expected + + setHomeEvent path = liftIO $ setEnv "HOME" (encodeString path) + + it "generates the correct matchingText on `:! cd ~/*` " $ + do ":! cd ~/*" `shouldHaveMatchingText` ("~/" :: String) + + it "generates the correct matchingText on `:load ~/*` " $ + do ":load ~/*" `shouldHaveMatchingText` ("~/" :: String) + + it "generates the correct matchingText on `:l ~/*` " $ + do ":l ~/*" `shouldHaveMatchingText` ("~/" :: String) + +evalTests = do + describe "Code Evaluation" $ do + it "evaluates expressions" $ do + "3" `becomes` ["3"] + "3+5" `becomes` ["8"] + "print 3" `becomes` ["3"] + [hereLit| + let x = 11 + z = 10 in + x+z + |] `becomes` ["21"] + + it "evaluates multiline expressions" $ do + [hereLit| + import Control.Monad + forM_ [1, 2, 3] $ \x -> + print x + |] `becomes` ["1\n2\n3"] + + it "evaluates function declarations silently" $ do + [hereLit| + fun :: [Int] -> Int + fun [] = 3 + fun (x:xs) = 10 + fun [1, 2] + |] `becomes` ["10"] + + it "evaluates data declarations" $ do + [hereLit| + data X = Y Int + | Z String + deriving (Show, Eq) + print [Y 3, Z "No"] + print (Y 3 == Z "No") + |] `becomes` ["[Y 3,Z \"No\"]", "False"] + + it "evaluates do blocks in expressions" $ do + [hereLit| + show (show (do + Just 10 + Nothing + Just 100)) + |] `becomes` ["\"\\\"Nothing\\\"\""] + + it "is silent for imports" $ do + "import Control.Monad" `becomes` [] + "import qualified Control.Monad" `becomes` [] + "import qualified Control.Monad as CM" `becomes` [] + "import Control.Monad (when)" `becomes` [] + + it "evaluates directives" $ do + ":typ 3" `becomes` ["forall a. Num a => a"] + ":in String" `pages` ["type String = [Char] \t-- Defined in `GHC.Base'"] + +parserTests = do + layoutChunkerTests + moduleNameTests + parseStringTests + +layoutChunkerTests = describe "Layout Chunk" $ do + it "chunks 'a string'" $ + map unloc (layoutChunks "a string") `shouldBe` ["a string"] + + it "chunks 'a\\n string'" $ + map unloc (layoutChunks "a\n string") `shouldBe` ["a\n string"] + + it "chunks 'a\\n string\\nextra'" $ + map unloc (layoutChunks "a\n string\nextra") `shouldBe` ["a\n string","extra"] + + it "chunks strings with too many lines" $ + map unloc (layoutChunks "a\n\nstring") `shouldBe` ["a","string"] + + it "parses multiple exprs" $ do + let text = [hereLit| + first + + second + third + + fourth + |] + layoutChunks text `shouldBe` + [Located 2 "first", + Located 4 "second", + Located 5 "third", + Located 7 "fourth"] + +moduleNameTests = describe "Get Module Name" $ do + it "parses simple module names" $ + "module A where\nx = 3" `named` ["A"] + it "parses module names with dots" $ + "module A.B where\nx = 3" `named` ["A", "B"] + it "parses module names with exports" $ + "module A.B.C ( x ) where x = 3" `named` ["A", "B", "C"] + it "errors when given unnamed modules" $ do + doGhc (getModuleName "x = 3") `shouldThrow` anyException + where + named str result = do + res <- doGhc $ getModuleName str + res `shouldBe` result + +parseStringTests = describe "Parser" $ do + it "parses empty strings" $ + parses "" `like` [] + + it "parses simple imports" $ + "import Data.Monoid" `is` Import + + it "parses simple arithmetic" $ + "3 + 5" `is` Expression + + it "parses :type" $ + parses ":type x\n:ty x" `like` [ + Directive GetType "x", + Directive GetType "x" + ] + + it "parses :info" $ + parses ":info x\n:in x" `like` [ + Directive GetInfo "x", + Directive GetInfo "x" + ] + + it "parses :help and :?" $ + parses ":? x\n:help x" `like` [ + Directive GetHelp "x", + Directive GetHelp "x" + ] + + it "parses :set x" $ + parses ":set x" `like` [ + Directive SetOpt "x" + ] + + it "parses :extension x" $ + parses ":ex x\n:extension x" `like` [ + Directive SetExtension "x", + Directive SetExtension "x" + ] + + it "fails to parse :nope" $ + parses ":nope goodbye" `like` [ + ParseError (Loc 1 1) "Unknown directive: 'nope'." + ] + + it "parses number followed by let stmt" $ + parses "3\nlet x = expr" `like` [ + Expression "3", + Statement "let x = expr" + ] + + it "parses let x in y" $ + "let x = 3 in x + 3" `is` Expression + + it "parses a data declaration" $ + "data X = Y Int" `is` Declaration + + it "parses number followed by type directive" $ + parses "3\n:t expr" `like` [ + Expression "3", + Directive GetType "expr" + ] + + it "parses a <- statement" $ + "y <- print 'no'" `is` Statement + + it "parses a <- stmt followed by let stmt" $ + parses "y <- do print 'no'\nlet x = expr" `like` [ + Statement "y <- do print 'no'", + Statement "let x = expr" + ] + + it "parses <- followed by let followed by expr" $ + parses "y <- do print 'no'\nlet x = expr\nexpression" `like` [ + Statement "y <- do print 'no'", + Statement "let x = expr", + Expression "expression" + ] + + it "parses two print statements" $ + parses "print yes\nprint no" `like` [ + Expression "print yes", + Expression "print no" + ] + + it "parses a pattern-maching function declaration" $ + "fun [] = 10" `is` Declaration + + it "parses a function decl followed by an expression" $ + parses "fun [] = 10\nprint 'h'" `like` [ + Declaration "fun [] = 10", + Expression "print 'h'" + ] + + it "parses list pattern matching fun decl" $ + "fun (x : xs) = 100" `is` Declaration + + it "parses two pattern matches as the same declaration" $ + "fun [] = 10\nfun (x : xs) = 100" `is` Declaration + + it "parses a type signature followed by a declaration" $ + "fun :: [a] -> Int\nfun [] = 10\nfun (x : xs) = 100" `is` Declaration + + it "parases a simple module" $ + "module A where x = 3" `is` Module + + it "parses a module with an export" $ + "module B (x) where x = 3" `is` Module + + it "breaks when a let is incomplete" $ + parses "let x = 3 in" `like` [ + ParseError (Loc 1 13) "parse error (possibly incorrect indentation or mismatched brackets)" + ] + + it "breaks without data kinds" $ + parses "data X = 3" `like` [ + ParseError (Loc 1 10) "Illegal literal in type (use -XDataKinds to enable): 3" + ] + + it "parses statements after imports" $ do + parses "import X\nprint 3" `like` [ + Import "import X", + Expression "print 3" + ] + parses "import X\n\nprint 3" `like` [ + Import "import X", + Expression "print 3" + ] + it "ignores blank lines properly" $ + [hereLit| + test arg = hello + where + x = y + + z = w + |] `is` Declaration + it "doesn't break on long strings" $ do + let longString = concat $ replicate 20 "hello " + ("img ! src \"" ++ longString ++ "\" ! width \"500\"") `is` Expression + + it "parses do blocks in expression" $ do + [hereLit| + show (show (do + Just 10 + Nothing + Just 100)) + |] `is` Expression + it "correctly locates parsed items" $ do + let go = doGhc . parseString + go [hereLit| + first + + second + |] >>= (`shouldBe` [Located 2 (Expression "first"), + Located 4 (Expression "second")]) + + +parseShellTests = + describe "Parsing Shell Commands" $ do + test "A" ["A"] + test ":load A" [":load", "A"] + test ":!l ~/Downloads/MyFile\\ Has\\ Spaces.txt" + [":!l", "~/Downloads/MyFile\\ Has\\ Spaces.txt"] + test ":!l \"~/Downloads/MyFile Has Spaces.txt\" /Another/File\\ WithSpaces.doc" + [":!l", "~/Downloads/MyFile Has Spaces.txt", "/Another/File\\ WithSpaces.doc" ] + where + test string expected = + it ("parses " ++ string ++ " correctly") $ + string `shouldParseTo` expected + + shouldParseTo xs ys = fun ys (parseShell xs) + where fun ys (Right xs') = xs' `shouldBe` ys + fun ys (Left e) = assertFailure $ "parseShell returned error: \n" ++ show e + + +-- Useful HSpec expectations ---- +--------------------------------- + +shouldBeAmong :: (Show a, Eq a) => [a] -> [a] -> Expectation +-- | +-- @sublist \`shouldbeAmong\` list@ sets the expectation that @sublist@ elements are +-- among those in @list@. +sublist `shouldBeAmong` list = assertBool errorMsg + $ and [x `elem` list | x <- sublist] + where + errorMsg = show list ++ " doesn't contain " ++ show sublist diff --git a/src/IHaskell/Display.hs b/src/IHaskell/Display.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Display.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-} +module IHaskell.Display ( + IHaskellDisplay(..), + plain, html, png, jpg, svg, latex, + serializeDisplay, + Width, Height, Base64, + encode64, base64, + Display(..), + DisplayData(..), + ) where + +import ClassyPrelude +import Data.Serialize as Serialize +import Data.ByteString hiding (map) +import Data.String.Utils (rstrip) +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as Char + +import IHaskell.Types + +type Base64 = ByteString + +-- | A class for displayable Haskell types. +-- +-- IHaskell's displaying of results behaves as if these two +-- overlapping/undecidable instances also existed: +-- +-- > instance (Show a) => IHaskellDisplay a +-- > instance Show a where shows _ = id +class IHaskellDisplay a where + display :: a -> IO Display + +-- | these instances cause the image, html etc. which look like: +-- +-- > Display +-- > [Display] +-- > IO [Display] +-- > IO (IO Display) +-- +-- be run the IO and get rendered (if the frontend allows it) in the pretty +-- form. +instance IHaskellDisplay a => IHaskellDisplay (IO a) where + display = (display =<<) + +instance IHaskellDisplay Display where + display = return + +instance IHaskellDisplay DisplayData where + display disp = return $ Display [disp] + +instance IHaskellDisplay a => IHaskellDisplay [a] where + display disps = do + displays <- mapM display disps + return $ ManyDisplay displays + +-- | Encode many displays into a single one. All will be output. +many :: [Display] -> Display +many = ManyDisplay + +-- | Generate a plain text display. +plain :: String -> DisplayData +plain = DisplayData PlainText . Char.pack . rstrip + +-- | Generate an HTML display. +html :: String -> DisplayData +html = DisplayData MimeHtml . Char.pack + +-- | Genreate an SVG display. +svg :: String -> DisplayData +svg = DisplayData MimeSvg . Char.pack + +-- | Genreate a LaTeX display. +latex :: String -> DisplayData +latex = DisplayData MimeLatex . Char.pack + +-- | Generate a PNG display of the given width and height. Data must be +-- provided in a Base64 encoded manner, suitable for embedding into HTML. +-- The @base64@ function may be used to encode data into this format. +png :: Width -> Height -> Base64 -> DisplayData +png width height = DisplayData (MimePng width height) + +-- | Generate a JPG display of the given width and height. Data must be +-- provided in a Base64 encoded manner, suitable for embedding into HTML. +-- The @base64@ function may be used to encode data into this format. +jpg :: Width -> Height -> Base64 -> DisplayData +jpg width height = DisplayData (MimeJpg width height) + +-- | Convert from a string into base 64 encoded data. +encode64 :: String -> Base64 +encode64 str = base64 $ Char.pack str + +-- | Convert from a ByteString into base 64 encoded data. +base64 :: ByteString -> Base64 +base64 = Base64.encode + +-- | For internal use within IHaskell. +-- Serialize displays to a ByteString. +serializeDisplay :: Display -> ByteString +serializeDisplay = Serialize.encode diff --git a/src/IHaskell/Eval/Completion.hs b/src/IHaskell/Eval/Completion.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Eval/Completion.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-} +{- | +Description : Generates tab completion options. + +This has a limited amount of context sensitivity. It distinguishes between four contexts at the moment: +- import statements (completed using modules) +- identifiers (completed using in scope values) +- extensions via :ext (completed using GHC extensions) +- qualified identifiers (completed using in-scope values) + +-} +module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where + +import ClassyPrelude hiding (liftIO) +--import Prelude + +import Control.Applicative ((<$>)) +import Data.ByteString.UTF8 hiding (drop, take) +import Data.Char +import Data.List (nub, init, last, head, elemIndex) +import Data.List.Split +import Data.List.Split.Internals +import Data.Maybe +import Data.String.Utils (strip, startswith, endswith, replace) +import qualified Data.String.Utils as StringUtils +import System.Environment (getEnv) + +import GHC +import DynFlags +import GhcMonad +import PackageConfig +import Outputable (showPpr) + + +import System.Directory +import System.FilePath +import MonadUtils (MonadIO) + +import System.Console.Haskeline.Completion + +import IHaskell.Types +import IHaskell.Eval.Evaluate (Interpreter) +import IHaskell.Eval.ParseShell (parseShell) + + +data CompletionType + = Empty + | Identifier String + | DynFlag String + | Qualified String String + | ModuleName String String + | HsFilePath String String + | FilePath String String + | KernelOption String + deriving (Show, Eq) + +complete :: String -> Int -> Interpreter (String, [String]) +complete line pos = do + flags <- getSessionDynFlags + rdrNames <- map (showPpr flags) <$> getRdrNamesInScope + scopeNames <- nub <$> map (showPpr flags) <$> getNamesInScope + let isQualified = ('.' `elem`) + unqualNames = nub $ filter (not . isQualified) rdrNames + qualNames = nub $ scopeNames ++ filter isQualified rdrNames + + let Just db = pkgDatabase flags + getNames = map moduleNameString . exposedModules + moduleNames = nub $ concatMap getNames db + + let target = completionTarget line pos + + let matchedText = case completionType line pos target of + HsFilePath _ match -> match + FilePath _ match -> match + otherwise -> intercalate "." target + + options <- + case completionType line pos target of + Empty -> return [] + + Identifier candidate -> + return $ filter (candidate `isPrefixOf`) unqualNames + + Qualified moduleName candidate -> do + trueName <- getTrueModuleName moduleName + let prefix = intercalate "." [trueName, candidate] + completions = filter (prefix `isPrefixOf`) qualNames + falsifyName = replace trueName moduleName + return $ map falsifyName completions + + ModuleName previous candidate -> do + let prefix = if null previous + then candidate + else intercalate "." [previous, candidate] + return $ filter (prefix `isPrefixOf`) moduleNames + + DynFlag ext -> do + 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 + + HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor + + FilePath lineUpToCursor match -> completePath lineUpToCursor + + KernelOption str -> return $ + filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts) + + return (matchedText, options) + +getTrueModuleName :: String -> Interpreter String +getTrueModuleName name = do + -- Only use the things that were actually imported + let onlyImportDecl (IIDecl decl) = Just decl + onlyImportDecl _ = Nothing + + -- Get all imports that we use. + imports <- catMaybes <$> map onlyImportDecl <$> getContext + + -- Find the ones that have a qualified name attached. + -- If this name isn't one of them, it already is the true name. + flags <- getSessionDynFlags + let qualifiedImports = filter (isJust . ideclAs) imports + hasName imp = name == (showPpr flags . fromJust . ideclAs) imp + case find hasName qualifiedImports of + Nothing -> return name + Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp + +-- | Get which type of completion this is from the surrounding context. +completionType :: String -- ^ The line on which the completion is being done. + -> Int -- ^ Location of the cursor in the line. + -> [String] -- ^ The identifier being completed (pieces separated by dots). + -> CompletionType +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 + | startswith ":l" stripped + = case parseShell lineUpToCursor of + Right xs -> HsFilePath lineUpToCursor $ if endswith (last xs) lineUpToCursor then (last xs) else [] + Left _ -> Empty + | startswith ":s" stripped + = DynFlag candidate + | startswith ":o" stripped + = KernelOption candidate + -- Use target for other completions. + -- If it's empty, no completion. + | null target + = Empty + | startswith "import" stripped && isModName + = ModuleName dotted candidate + | isModName && (not . null . init) target + = Qualified dotted candidate + | otherwise + = Identifier candidate + where stripped = strip line + dotted = dots target + candidate | null target = "" + | otherwise = last target + dots = intercalate "." . init + isModName = all isCapitalized (init target) + isCapitalized = isUpper . head + lineUpToCursor = take loc line + + +-- | Get the word under a given cursor location. +completionTarget :: String -> Int -> [String] +completionTarget code cursor = expandCompletionPiece pieceToComplete + where + pieceToComplete = map fst <$> find (elem cursor . map snd) pieces + pieces = splitAlongCursor $ split splitter $ zip code [1 .. ] + splitter = defaultSplitter { + -- Split using only the characters, which are the first elements of + -- the (char, index) tuple + delimiter = Delimiter [uncurry isDelim], + -- Condense multiple delimiters into one and then drop them. + condensePolicy = Condense, + delimPolicy = Drop + } + + isDelim :: Char -> Int -> Bool + isDelim char idx = char `elem` neverIdent || isSymbol char + + splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]] + splitAlongCursor [] = [] + splitAlongCursor (x:xs) = + case elemIndex cursor $ map snd x of + Nothing -> x:splitAlongCursor xs + Just idx -> take (idx + 1) x:drop (idx + 1) x:splitAlongCursor xs + + -- These are never part of an identifier. + neverIdent :: String + neverIdent = " \n\t(),{}[]\\'\"`" + + expandCompletionPiece Nothing = [] + expandCompletionPiece (Just str) = splitOn "." str + +getHome :: IO String +getHome = do + homeEither <- try $ getEnv "HOME" :: IO (Either SomeException String) + return $ case homeEither of + Left _ -> "~" + Right home -> home + +dirExpand :: String -> IO String +dirExpand str = do + home <- getHome + return $ replace "~" home str + +unDirExpand :: String -> IO String +unDirExpand str = do + home <- getHome + return $ replace home "~" str + +completePath :: String -> Interpreter [String] +completePath line = completePathFilter acceptAll acceptAll line "" + where acceptAll = const True + +completePathWithExtensions :: [String] -> String -> Interpreter [String] +completePathWithExtensions extensions line = + completePathFilter (extensionIsOneOf extensions) acceptAll line "" + where + acceptAll = const True + extensionIsOneOf exts str = any correctEnding exts + where correctEnding ext = endswith ext str + +completePathFilter :: (String -> Bool) -- ^ File filter: test whether to include this file. + -> (String -> Bool) -- ^ Directory filter: test whether to include this directory. + -> String -- ^ Line contents to the left of the cursor. + -> String -- ^ Line contents to the right of the cursor. + -> Interpreter [String] +completePathFilter includeFile includeDirectory left right = liftIO $ do + -- Get the completions from Haskeline. It has a bit of a strange API. + expanded <- dirExpand left + completions <- map replacement <$> snd <$> completeFilename (reverse expanded, right) + + -- Split up into files and directories. + -- Filter out ones we don't want. + areDirs <- mapM doesDirectoryExist completions + let dirs = filter includeDirectory $ map fst $ filter snd $ zip completions areDirs + files = filter includeFile $ map fst $ filter (not . snd) $ zip completions areDirs + + -- Return directories before files. However, stick everything that starts + -- with a dot after everything else. If we wanted to keep original + -- order, we could instead use + -- filter (`elem` (dirs ++ files)) completions + suggestions <- mapM unDirExpand $ dirs ++ files + let isHidden str = startswith "." . last . StringUtils.split "/" $ + if endswith "/" str + then init str + else str + visible = filter (not . isHidden) suggestions + hidden = filter isHidden suggestions + return $ visible ++ hidden + diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Eval/Evaluate.hs @@ -0,0 +1,1078 @@ +{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances, PatternGuards #-} + +{- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs + a statement, declaration, import, or directive. + +This module exports all functions used for evaluation of IHaskell input. +-} +module IHaskell.Eval.Evaluate ( + interpret, evaluate, Interpreter, liftIO, typeCleaner, globalImports + ) where + +import ClassyPrelude hiding (liftIO, hGetContents, try) +import Control.Concurrent (forkIO, threadDelay) +import Prelude (putChar, head, tail, last, init, (!!)) +import Data.List.Utils +import Data.List(findIndex, and) +import Data.String.Utils +import Text.Printf +import Data.Char as Char +import Data.Dynamic +import Data.Typeable +import qualified Data.Serialize as Serialize +import System.Directory +import Filesystem.Path.CurrentOS (encodeString) +import System.Posix.IO +import System.IO (hGetChar, hFlush) +import System.Random (getStdGen, randomRs) +import Unsafe.Coerce +import Control.Monad (guard) +import System.Process +import System.Exit +import Data.Maybe (fromJust) +import qualified Control.Monad.IO.Class as MonadIO (MonadIO, liftIO) +import qualified MonadUtils (MonadIO, liftIO) +import System.Environment (getEnv) + +import NameSet +import Name +import PprTyThing +import InteractiveEval +import DynFlags +import Type +import Exception (gtry) +import HscTypes +import HscMain +import qualified Linker +import TcType +import Unify +import InstEnv +import GhcMonad (liftIO, withSession) +import GHC hiding (Stmt, TypeSig) +import GHC.Paths +import Exception hiding (evaluate) +import Outputable +import Packages +import Module +import qualified Pretty +import FastString +import Bag +import ErrUtils (errMsgShortDoc, errMsgExtraInfo) + +import qualified System.IO.Strict as StrictIO + +import IHaskell.Types +import IHaskell.IPython +import IHaskell.Eval.Parser +import IHaskell.Eval.Lint +import IHaskell.Display +import qualified IHaskell.Eval.Hoogle as Hoogle +import IHaskell.Eval.Util + +import Paths_ihaskell (version) +import Data.Version (versionBranch) + +data ErrorOccurred = Success | Failure deriving (Show, Eq, Ord) + +debug :: Bool +debug = False + +ignoreTypePrefixes :: [String] +ignoreTypePrefixes = ["GHC.Types", "GHC.Base", "GHC.Show", "System.IO", + "GHC.Float", ":Interactive", "GHC.Num", "GHC.IO", + "GHC.Integer.Type"] + +typeCleaner :: String -> String +typeCleaner = useStringType . foldl' (.) id (map (`replace` "") fullPrefixes) + where + fullPrefixes = map (++ ".") ignoreTypePrefixes + useStringType = replace "[Char]" "String" + +write :: GhcMonad m => String -> m () +write x = when debug $ liftIO $ hPutStrLn stderr $ "DEBUG: " ++ x + +type Interpreter = Ghc + +instance MonadIO.MonadIO Interpreter where + liftIO = MonadUtils.liftIO + +globalImports :: [String] +globalImports = + [ "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" + ] + + + +-- | 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 + + -- If we're in a sandbox, add the relevant package database + sandboxPackages <- liftIO getSandboxPackageConf + let pkgConfs = case sandboxPackages of + Nothing -> extraPkgConfs dflags + Just path -> + let pkg = PkgConfFile path in + (pkg:) . extraPkgConfs dflags + + void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted, + ghcLink = LinkInMemory, + pprCols = 300, + extraPkgConfs = pkgConfs } + + initializeImports + + -- Close stdin so it can't be used. + -- Otherwise it'll block the kernel forever. + dir <- liftIO getIHaskellDir + let cmd = printf "IPython.Stdin.fixStdin \"%s\"" dir + when allowedStdin $ void $ + runStmt cmd RunToCompletion + + initializeItVariable + + -- Run the rest of the interpreter + action + +-- | Initialize our GHC session with imports and a value for 'it'. +initializeImports :: Interpreter () +initializeImports = do + -- Load packages that start with ihaskell-*, aren't just IHaskell, + -- and depend directly on the right version of the ihaskell library + dflags <- getSessionDynFlags + displayPackages <- liftIO $ do + (dflags, _) <- initPackages dflags + let Just db = pkgDatabase dflags + packageNames = map (packageIdString . packageConfigId) db + + initStr = "ihaskell-" + -- "ihaskell-1.2.3.4" + iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version)) + + dependsOnRight pkg = not $ null $ do + pkg <- db + depId <- depends pkg + dep <- filter ((== depId) . installedPackageId) db + guard (iHaskellPkgName `isPrefixOf` packageIdString (packageConfigId dep)) + + -- ideally the Paths_ihaskell module could provide a way to get the + -- hash too (ihaskell-0.2.0.5-f2bce922fa881611f72dfc4a854353b9), + -- for now. Things will end badly if you also happen to have an + -- ihaskell-0.2.0.5-ce34eadc18cf2b28c8d338d0f3755502 installed. + iHaskellPkg = case filter (== iHaskellPkgName) packageNames of + [x] -> x + [] -> error ("cannot find required haskell library: "++iHaskellPkgName) + _ -> error ("multiple haskell packages "++iHaskellPkgName++" found") + + displayPkgs = [ pkgName + | pkgName <- packageNames, + Just (x:_) <- [stripPrefix initStr pkgName], + isAlpha x] + + return displayPkgs + + -- Generate import statements all Display modules. + let capitalize :: String -> String + capitalize (first:rest) = Char.toUpper first : rest + + importFmt = "import IHaskell.Display.%s" + + toImportStmt :: String -> String + toImportStmt = printf importFmt . capitalize . (!! 1) . split "-" + + displayImports = map toImportStmt displayPackages + + -- Import implicit prelude. + importDecl <- parseImportDecl "import Prelude" + let implicitPrelude = importDecl { ideclImplicit = True } + + -- Import modules. + mapM_ (write . ("Importing " ++ )) displayImports + imports <- mapM parseImportDecl $ globalImports ++ displayImports + setContext $ map IIDecl $ implicitPrelude : imports + +-- | Give a value for the `it` variable. +initializeItVariable :: Interpreter () +initializeItVariable = do + -- This is required due to the way we handle `it` in the wrapper + -- statements - if it doesn't exist, the first statement will fail. + write "Setting `it` to unit." + void $ runStmt "let it = ()" RunToCompletion + +-- | Publisher for IHaskell outputs. The first argument indicates whether +-- this output is final (true) or intermediate (false). +type Publisher = (EvaluationResult -> IO ()) + +-- | Output of a command evaluation. +data EvalOut = EvalOut { + evalStatus :: ErrorOccurred, + evalResult :: Display, + evalState :: KernelState, + evalPager :: String + } + +-- | Evaluate some IPython input code. +evaluate :: KernelState -- ^ The kernel state. + -> String -- ^ Haskell code or other interpreter commands. + -> (EvaluationResult -> IO ()) -- ^ Function used to publish data outputs. + -> Interpreter KernelState +evaluate kernelState code output = do + cmds <- parseString (strip code) + let execCount = getExecutionCounter kernelState + + when (getLintStatus kernelState /= LintOff) $ liftIO $ do + lintSuggestions <- lint cmds + unless (noResults lintSuggestions) $ + output $ FinalResult lintSuggestions "" + + updated <- runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount]) + return updated { + getExecutionCounter = execCount + 1 + } + where + noResults (Display res) = null res + noResults (ManyDisplay res) = all noResults res + + runUntilFailure :: KernelState -> [CodeBlock] -> Interpreter KernelState + runUntilFailure state [] = return state + runUntilFailure state (cmd:rest) = do + evalOut <- evalCommand output cmd state + + -- Output things only if they are non-empty. + let result = evalResult evalOut + helpStr = evalPager evalOut + unless (noResults result && null helpStr) $ + liftIO $ output $ FinalResult result helpStr + + let newState = evalState evalOut + case evalStatus evalOut of + Success -> runUntilFailure newState rest + Failure -> return newState + + storeItCommand execCount = Statement $ printf "let it%d = it" execCount + +safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut +safely state = ghandle handler . ghandle sourceErrorHandler + where + handler :: SomeException -> Interpreter EvalOut + handler exception = + return EvalOut { + evalStatus = Failure, + evalResult = displayError $ show exception, + evalState = state, + evalPager = "" + } + + sourceErrorHandler :: SourceError -> Interpreter EvalOut + sourceErrorHandler srcerr = do + let msgs = bagToList $ srcErrorMessages srcerr + errStrs <- forM msgs $ \msg -> do + shortStr <- doc $ errMsgShortDoc msg + contextStr <- doc $ errMsgExtraInfo msg + return $ unlines [shortStr, contextStr] + + let fullErr = unlines errStrs + + return EvalOut { + evalStatus = Failure, + evalResult = displayError fullErr, + evalState = state, + 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 + -> Interpreter Display + -> Interpreter EvalOut +wrapExecution state exec = safely state $ exec >>= \res -> + return EvalOut { + evalStatus = Success, + evalResult = res, + evalState = state, + evalPager = "" + } + +-- | Set dynamic flags. +-- +-- adapted from GHC's InteractiveUI.hs (newDynFlags) +setDynFlags :: [String] -> Interpreter [ErrMsg] +setDynFlags ext = do + 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' ]) + +-- | 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 + + flags <- getSessionDynFlags + 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 + + -- Write the module contents to a temporary file in our work directory + namePieces <- getModuleName contents + liftIO (print namePieces) + let directory = "./" ++ intercalate "/" (init namePieces) ++ "/" + filename = last namePieces ++ ".hs" + liftIO $ do + createDirectoryIfMissing True directory + writeFile (fpFromString $ directory ++ filename) contents + + -- Clear old modules of this name + let modName = intercalate "." namePieces + removeTarget $ TargetModule $ mkModuleName modName + removeTarget $ TargetFile filename Nothing + + -- Remember which modules we've loaded before. + importedModules <- getContext + + let -- Get the dot-delimited pieces of the module name. + moduleNameOf :: InteractiveImport -> [String] + moduleNameOf (IIDecl decl) = split "." . moduleNameString . unLoc . ideclName $ decl + moduleNameOf (IIModule imp) = split "." . moduleNameString $ imp + + -- Return whether this module prevents the loading of the one we're + -- trying to load. If a module B exist, we cannot load A.B. All + -- modules must have unique last names (where A.B has last name B). + -- However, we *can* just reload a module. + preventsLoading mod = + let pieces = moduleNameOf mod in + last namePieces == last pieces && namePieces /= pieces + + -- If we've loaded anything with the same last name, we can't use this. + -- Otherwise, GHC tries to load the original *.hs fails and then fails. + case find preventsLoading importedModules of + -- If something prevents loading this module, return an error. + Just previous -> do + let prevLoaded = intercalate "." (moduleNameOf previous) + return $ displayError $ + printf "Can't load module %s because already loaded %s" modName prevLoaded + + -- 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 + } + +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 + write $ "Extension: " ++ opts + evalCommand a (Directive SetDynFlag (concatMap (" -X"++) (words opts))) 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 = "" + } + +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 + +evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do + write $ "Load: " ++ name + + let filename = if endswith ".hs" name + then name + else name ++ ".hs" + let modName = replace "/" "." $ + if endswith ".hs" name + then replace ".hs" "" name + else name + + doLoadModule filename modName + +evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $ liftIO $ + case words cmd of + "cd":dirs -> do + -- Get home so we can replace '~` with it. + homeEither <- try $ getEnv "HOME" :: IO (Either SomeException String) + let home = case homeEither of + Left _ -> "~" + Right val -> val + + let directory = replace "~" home $ unwords dirs + exists <- doesDirectoryExist directory + if exists + then do + setCurrentDirectory directory + return $ mempty + else + return $ displayError $ printf "No such directory: '%s'" directory + cmd -> do + (readEnd, writeEnd) <- createPipe + handle <- fdToHandle writeEnd + pipe <- fdToHandle readEnd + let initProcSpec = shell $ unwords cmd + procSpec = initProcSpec { + std_in = Inherit, + std_out = UseHandle handle, + std_err = UseHandle handle + } + (_, _, _, process) <- createProcess procSpec + + -- Accumulate output from the process. + outputAccum <- liftIO $ newMVar "" + + -- Start a loop to publish intermediate results. + let + -- Compute how long to wait between reading pieces of the output. + -- `threadDelay` takes an argument of microseconds. + ms = 1000 + delay = 100 * ms + + -- Maximum size of the output (after which we truncate). + maxSize = 100 * 1000 + incSize = 200 + output str = publish $ IntermediateResult $ Display [plain str] + + loop = do + -- Wait and then check if the computation is done. + threadDelay delay + + -- Read next chunk and append to accumulator. + nextChunk <- readChars pipe "\n" incSize + modifyMVar_ outputAccum (return . (++ nextChunk)) + + -- Check if we're done. + exitCode <- getProcessExitCode process + let computationDone = isJust exitCode + + when computationDone $ do + nextChunk <- readChars pipe "" maxSize + modifyMVar_ outputAccum (return . (++ nextChunk)) + + if not computationDone + then do + -- Write to frontend and repeat. + readMVar outputAccum >>= output + loop + else do + out <- readMVar outputAccum + case fromJust exitCode of + ExitSuccess -> return $ Display [plain out] + ExitFailure code -> do + let errMsg = "Process exited with error code " ++ show code + htmlErr = printf "%s" errMsg + return $ Display [plain $ out ++ "\n" ++ errMsg, + html $ printf "%s" out ++ htmlErr] + + loop + + +-- This is taken largely from GHCi's info section in InteractiveUI. +evalCommand _ (Directive GetHelp _) state = do + write "Help via :help or :?." + return EvalOut { + evalStatus = Success, + evalResult = Display [out], + evalState = state, + evalPager = "" + } + where out = plain $ intercalate "\n" + ["The following commands are available:" + ," :extension - Enable a GHC extension." + ," :extension No - Disable a GHC extension." + ," :type - Print expression type." + ," :info - Print all info for a name." + ," :hoogle - Search for a query on Hoogle." + ," :doc - Get documentation for an identifier via Hogole." + ," :set -XFlag -Wall - Set an option (like ghci)." + ," :option - Set an option." + ," :option no- - Unset an option." + ," :?, :help - Show this help text." + ,"" + ,"Any prefix of the commands will also suffice, e.g. use :ty for :type." + ,"" + ,"Options:" + ," lint - enable or disable linting." + ," svg - use svg output (cannot be resized)." + ," show-types - show types of all bound names" + ," show-errors - display Show instance missing errors normally." + ] + +-- This is taken largely from GHCi's info section in InteractiveUI. +evalCommand _ (Directive GetInfo str) state = safely state $ do + write $ "Info: " ++ str + -- Get all the info for all the names we're given. + names <- parseName str + maybeInfos <- mapM getInfo names + + -- Filter out types that have parents in the same set. + -- GHCi also does this. + let getType (theType, _, _) = theType + infos = catMaybes maybeInfos + allNames = mkNameSet $ map (getName . getType) infos + hasParent info = case tyThingParent_maybe (getType info) of + Just parent -> getName parent `elemNameSet` allNames + Nothing -> False + filteredOutput = filter (not . hasParent) infos + + -- Convert to textual data. + let printInfo (thing, fixity, classInstances) = + pprTyThingInContextLoc False thing $$ showFixity fixity $$ vcat (map GHC.pprInstance classInstances) + where + showFixity fixity = + if fixity == GHC.defaultFixity + then empty + else ppr fixity <+> pprInfixName (getName thing) + + -- Print nicely. + strings <- mapM (doc . printInfo) filteredOutput + let output = case getFrontend state of + IPythonConsole -> unlines strings + IPythonNotebook -> unlines (map htmlify strings) + htmlify str = + printf "
" str + ++ script + script = + "" + + return EvalOut { + evalStatus = Success, + evalResult = mempty, + evalState = state, + evalPager = output + } + +evalCommand _ (Directive SearchHoogle query) state = safely state $ do + results <- liftIO $ Hoogle.search query + return $ hoogleResults state results + +evalCommand _ (Directive GetDoc query) state = safely state $ do + results <- liftIO $ Hoogle.document query + return $ hoogleResults state results + +evalCommand output (Statement stmt) state = wrapExecution state $ do + write $ "Statement:\n" ++ stmt + let outputter str = output $ IntermediateResult $ Display [plain str] + (printed, result) <- capturedStatement outputter stmt + case result of + RunOk names -> do + dflags <- getSessionDynFlags + + let allNames = map (showPpr dflags) names + isItName name = + name == "it" || + name == "it" ++ show (getExecutionCounter state) + nonItNames = filter (not . isItName) allNames + output = [plain printed | not . null $ strip printed] + + write $ "Names: " ++ show allNames + + -- Display the types of all bound names if the option is on. + -- This is similar to GHCi :set +t. + if not $ useShowTypes state + then return $ Display output + else do + -- Get all the type strings. + types <- forM nonItNames $ \name -> do + theType <- showSDocUnqual dflags . ppr <$> exprType name + return $ name ++ " :: " ++ theType + + let joined = unlines types + htmled = unlines $ map formatGetType types + + return $ case extractPlain output of + "" -> Display [html htmled] + + -- Return plain and html versions. + -- Previously there was only a plain version. + text -> Display + [plain $ joined ++ "\n" ++ text, + html $ htmled ++ mono text] + + RunException exception -> throw exception + RunBreak{} -> error "Should not break." + +evalCommand output (Expression expr) state = do + write $ "Expression:\n" ++ expr + + -- Try to use `display` to convert our type into the output + -- Dislay If typechecking fails and there is no appropriate + -- typeclass instance, this will throw an exception and thus `attempt` will + -- return False, and we just resort to plaintext. + let displayExpr = printf "(IHaskell.Display.display (%s))" expr :: String + canRunDisplay <- attempt $ exprType displayExpr + + if canRunDisplay + then useDisplay displayExpr + else do + -- Evaluate this expression as though it's just a statement. + -- The output is bound to 'it', so we can then use it. + evalOut <- evalCommand output (Statement expr) state + + let out = evalResult evalOut + showErr = isShowError out + + -- If evaluation failed, return the failure. If it was successful, we + -- may be able to use the IHaskellDisplay typeclass. + return $ if not showErr || useShowErrors state + then evalOut + else postprocessShowError evalOut + + where + -- Try to evaluate an action. Return True if it succeeds and False if + -- it throws an exception. The result of the action is discarded. + attempt :: Interpreter a -> Interpreter Bool + attempt action = gcatch (action >> return True) failure + where failure :: SomeException -> Interpreter Bool + failure _ = return False + + -- Check if the error is due to trying to print something that doesn't + -- implement the Show typeclass. + isShowError (ManyDisplay _) = False + isShowError (Display errs) = + -- Note that we rely on this error message being 'type cleaned', so + -- that `Show` is not displayed as GHC.Show.Show. + startswith "No instance for (Show" msg && + isInfixOf " arising from a use of `print'" msg + where msg = extractPlain errs + + isSvg (DisplayData mime _) = mime == MimeSvg + + removeSvg (Display disps) = Display $ filter (not . isSvg) disps + removeSvg (ManyDisplay disps) = ManyDisplay $ map removeSvg disps + + useDisplay displayExpr = wrapExecution state $ do + -- If there are instance matches, convert the object into + -- a Display. We also serialize it into a bytestring. We get + -- the bytestring as a dynamic and then convert back to + -- a bytestring, which we promptly unserialize. Note that + -- attempting to do this without the serialization to binary and + -- back gives very strange errors - all the types match but it + -- refuses to decode back into a Display. + -- Suppress output, so as not to mess up console. + out <- capturedStatement (const $ return ()) displayExpr + + displayedBytestring <- dynCompileExpr "IHaskell.Display.serializeDisplay it" + case fromDynamic displayedBytestring of + Nothing -> error "Expecting lazy Bytestring" + Just bytestring -> + case Serialize.decode bytestring of + Left err -> error err + Right display -> do + return $ + if useSvg state + then display + else removeSvg display + + postprocessShowError :: EvalOut -> EvalOut + postprocessShowError evalOut = evalOut { evalResult = Display $ map postprocess disps } + where + Display disps = evalResult evalOut + text = extractPlain disps + + postprocess (DisplayData MimeHtml _) = html $ printf fmt unshowableType (formatErrorWithClass "err-msg collapse" text) script + where + fmt = "
Unshowable:%s%s
" + script = unlines [ + "$('#unshowable').on('click', function(e) {", + " e.preventDefault();", + " var $this = $(this);", + " var $collapse = $this.closest('.collapse-group').find('.err-msg');", + " $collapse.collapse('toggle');", + "});" + ] + + postprocess other = other + + unshowableType = fromMaybe "" $ do + let pieces = words text + before = takeWhile (/= "arising") pieces + after = init $ unwords $ tail $ dropWhile (/= "(Show") before + + firstChar <- headMay after + return $ if firstChar == '(' + then init $ tail after + else after + + + +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 + + -- Display the types of all bound names if the option is on. + -- This is similar to GHCi :set +t. + if not $ useShowTypes state + then return mempty + else do + -- Get all the type strings. + types <- forM nonDataNames $ \name -> do + theType <- showSDocUnqual dflags . ppr <$> exprType name + return $ name ++ " :: " ++ theType + + return $ Display [html $ unlines $ map formatGetType types] + +evalCommand _ (TypeSignature sig) state = wrapExecution state $ + -- We purposefully treat this as a "success" because that way execution + -- continues. Empty type signatures are likely due to a parse error later + -- on, and we want that to be displayed. + return $ displayError $ "The type signature " ++ sig ++ + "\nlacks an accompanying binding." + +evalCommand _ (ParseError loc err) state = do + write "Parse Error." + return EvalOut { + evalStatus = Failure, + evalResult = displayError $ formatParseError loc err, + evalState = state, + evalPager = "" + } + + +hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut +hoogleResults state results = EvalOut { + evalStatus = Success, + evalResult = mempty, + evalState = state, + evalPager = output + } + where + fmt = + case getFrontend state of + IPythonNotebook -> Hoogle.HTML + IPythonConsole -> Hoogle.Plain + output = unlines $ map (Hoogle.render fmt) results + +-- Read from a file handle until we hit a delimiter or until we've read +-- as many characters as requested +readChars :: Handle -> String -> Int -> IO String + +-- If we're done reading, return nothing. +readChars handle delims 0 = return [] + +readChars handle delims nchars = do + -- Try reading a single character. It will throw an exception if the + -- handle is already closed. + tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char) + case tryRead of + Right char -> + -- If this is a delimiter, stop reading. + if char `elem` delims + then return [char] + else do + next <- readChars handle delims (nchars - 1) + return $ char:next + -- An error occurs at the end of the stream, so just stop reading. + Left _ -> return [] + + +doLoadModule :: String -> String -> Ghc Display +doLoadModule name modName = flip gcatch unload $ do + -- Compile loaded modules. + flags <- getSessionDynFlags + let objTarget = defaultObjectTarget + setSessionDynFlags flags{ hscTarget = objTarget } + + -- Remember which modules we've loaded before. + importedModules <- getContext + + -- Create a new target + target <- guessTarget name Nothing + addTarget target + result <- load LoadAllTargets + + -- Reset the context, since loading things screws it up. + initializeItVariable + + -- Add imports + importDecl <- parseImportDecl $ "import " ++ modName + let implicitImport = importDecl { ideclImplicit = True } + setContext $ IIDecl implicitImport : importedModules + + -- Switch back to interpreted mode. + flags <- getSessionDynFlags + setSessionDynFlags flags{ hscTarget = HscInterpreted } + + case result of + Succeeded -> return mempty + Failed -> return $ displayError $ "Failed to load module " ++ modName + where + unload :: SomeException -> Ghc Display + unload exception = do + -- Explicitly clear targets + setTargets [] + load LoadAllTargets + + initializeItVariable + return $ displayError $ "Failed to load module " ++ modName ++ ": " ++ show exception + +capturedStatement :: (String -> IO ()) -- ^ Function used to publish intermediate output. + -> String -- ^ Statement to evaluate. + -> Interpreter (String, RunResult) -- ^ Return the output and result. +capturedStatement output stmt = do + -- Generate random variable names to use so that we cannot accidentally + -- override the variables by using the right names in the terminal. + gen <- liftIO getStdGen + let + -- Variable names generation. + rand = take 20 $ randomRs ('0', '9') gen + var name = name ++ rand + + -- Variables for the pipe input and outputs. + readVariable = var "file_read_var_" + writeVariable = var "file_write_var_" + + -- Variable where to store old stdout. + oldVariable = var "old_var_" + + -- Variable used to store true `it` value. + itVariable = var "it_var_" + + voidpf str = printf $ str ++ " >> return ()" + + -- 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 "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 + , printf "let it = %s" itVariable + ] + pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable + + goStmt s = runStmt s RunToCompletion + + -- Initialize evaluation context. + forM_ initStmts goStmt + + -- Get the pipe to read printed output from. + -- This is effectively the source code of dynCompileExpr from GHC API's + -- InteractiveEval. However, instead of using a `Dynamic` as an + -- intermediary, it just directly reads the value. This is incredibly + -- unsafe! However, for some reason the `getContext` and `setContext` + -- required by dynCompileExpr (to import and clear Data.Dynamic) cause + -- issues with data declarations being updated (e.g. it drops newer + -- versions of data declarations for older ones for unknown reasons). + -- First, compile down to an HValue. + Just (_, hValues, _) <- withSession $ liftIO . flip hscStmt pipeExpr + -- Then convert the HValue into an executable bit, and read the value. + pipe <- liftIO $ do + fd <- head <$> unsafeCoerce hValues + fdToHandle fd + + -- Read from a file handle until we hit a delimiter or until we've read + -- as many characters as requested + let + readChars :: Handle -> String -> Int -> IO String + + -- If we're done reading, return nothing. + readChars handle delims 0 = return [] + + readChars handle delims nchars = do + -- Try reading a single character. It will throw an exception if the + -- handle is already closed. + tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char) + case tryRead of + Right char -> + -- If this is a delimiter, stop reading. + if char `elem` delims + then return [char] + else do + next <- readChars handle delims (nchars - 1) + return $ char:next + -- An error occurs at the end of the stream, so just stop reading. + Left _ -> return [] + + + -- Keep track of whether execution has completed. + completed <- liftIO $ newMVar False + finishedReading <- liftIO newEmptyMVar + outputAccum <- liftIO $ newMVar "" + + -- Start a loop to publish intermediate results. + let + -- Compute how long to wait between reading pieces of the output. + -- `threadDelay` takes an argument of microseconds. + ms = 1000 + delay = 100 * ms + + -- How much to read each time. + chunkSize = 100 + + -- Maximum size of the output (after which we truncate). + maxSize = 100 * 1000 + + loop = do + -- Wait and then check if the computation is done. + threadDelay delay + computationDone <- readMVar completed + + if not computationDone + then do + -- Read next chunk and append to accumulator. + nextChunk <- readChars pipe "\n" 100 + modifyMVar_ outputAccum (return . (++ nextChunk)) + + -- Write to frontend and repeat. + readMVar outputAccum >>= output + loop + else do + -- Read remainder of output and accumulate it. + nextChunk <- readChars pipe "" maxSize + modifyMVar_ outputAccum (return . (++ nextChunk)) + + -- We're done reading. + putMVar finishedReading True + + liftIO $ forkIO loop + + result <- gfinally (goStmt stmt) $ do + -- Execution is done. + liftIO $ modifyMVar_ completed (const $ return True) + + -- Finalize evaluation context. + forM_ postStmts goStmt + + -- Once context is finalized, reading can finish. + -- Wait for reading to finish to that the output accumulator is + -- completely filled. + liftIO $ takeMVar finishedReading + + printedOutput <- liftIO $ readMVar outputAccum + return (printedOutput, result) + +formatError :: ErrMsg -> String +formatError = formatErrorWithClass "err-msg" + +formatErrorWithClass :: String -> ErrMsg -> String +formatErrorWithClass cls = + printf "%s" cls . + replace "\n" "
" . + fixStdinError . + replace useDashV "" . + rstrip . + typeCleaner + where + useDashV = "\nUse -v to see a list of the files searched for." + isShowError err = + startswith "No instance for (Show" err && + isInfixOf " arising from a use of `print'" err + + +formatParseError :: StringLoc -> String -> ErrMsg +formatParseError (Loc line col) = + printf "Parse error (line %d, column %d): %s" line col + +formatGetType :: String -> String +formatGetType = printf "%s" + +formatType :: String -> Display +formatType typeStr = Display [plain typeStr, html $ formatGetType typeStr] + +displayError :: ErrMsg -> Display +displayError msg = Display [plain . fixStdinError . typeCleaner $ msg, html $ formatError msg] + +fixStdinError :: ErrMsg -> ErrMsg +fixStdinError err = + if isStdinErr err + then " is not available in IHaskell. Use special `inputLine` instead of `getLine`." + else err + where + isStdinErr err = startswith "" err + && "illegal operation (handle is closed)" `isInfixOf` err + +mono :: String -> String +mono = printf "%s" diff --git a/src/IHaskell/Eval/Hoogle.hs b/src/IHaskell/Eval/Hoogle.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Eval/Hoogle.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-} +module IHaskell.Eval.Hoogle ( + search, + document, + render, + OutputFormat(..), + HoogleResult + ) where + +import ClassyPrelude hiding (span, div) +import Text.Printf +import Network.HTTP +import Data.Aeson +import Data.String.Utils +import Data.List (elemIndex, (!!), last) +import Control.Monad (guard) +import qualified Data.ByteString.Lazy.Char8 as Char + + +import IHaskell.IPython + +-- | Types of formats to render output to. +data OutputFormat + = Plain -- ^ Render to plain text. + | HTML -- ^ Render to HTML. + +data HoogleResponse = HoogleResponse { + location :: String, + self :: String, + docs :: String + } + deriving (Eq, Show) + +data HoogleResult + = SearchResult HoogleResponse + | DocResult HoogleResponse + | NoResult String + deriving Show + +instance FromJSON [HoogleResponse] where + parseJSON (Object obj) = do + results <- obj .: "results" + mapM parseJSON results + + parseJSON _ = fail "Expected object with 'results' field." + +instance FromJSON HoogleResponse where + parseJSON (Object obj) = + HoogleResponse <$> + obj .: "location" <*> + obj .: "self" <*> + obj .: "docs" + + parseJSON _ = fail "Expected object with fields: location, self, docs" + +-- | Query Hoogle for the given string. +-- This searches Hoogle using the internet. It returns either an error +-- message or the successful JSON result. +query :: String -> IO (Either String String) +query str = do + let request = getRequest $ queryUrl str + response <- simpleHTTP request + return $ case response of + Left err -> Left $ show err + Right resp -> Right $ rspBody resp + where + queryUrl :: String -> String + queryUrl = printf "http://www.haskell.org/hoogle/?hoogle=%s&mode=json" . urlEncode + +-- | Search for a query on Hoogle. +-- Return all search results. +search :: String -> IO [HoogleResult] +search string = do + response <- query string + return $ case response of + Left err -> [NoResult err] + Right json -> + case eitherDecode $ Char.pack json of + Left err -> [NoResult err] + Right results -> + case map SearchResult results of + [] -> [NoResult "no matching identifiers found."] + res -> res + +-- | Look up an identifier on Hoogle. +-- Return documentation for that identifier. If there are many +-- identifiers, include documentation for all of them. +document :: String -> IO [HoogleResult] +document string = do + matchingResults <- filter matches <$> search string + let results = map toDocResult matchingResults + return $ case results of + [] -> [NoResult "no matching identifiers found."] + res -> res + where + matches (SearchResult resp) = + case split " " $ self resp of + name:_ -> strip string == strip name + _ -> False + matches _ = False + + toDocResult (SearchResult resp) = DocResult resp + +-- | Render a Hoogle search result into an output format. +render :: OutputFormat -> HoogleResult -> String +render Plain = renderPlain +render HTML = renderHtml + +-- | Render a Hoogle result to plain text. +renderPlain :: HoogleResult -> String + +renderPlain (NoResult res) = + "No response available: " ++ res + +renderPlain (SearchResult resp) = + printf "%s\nURL: %s\n%s" + (self resp) + (location resp) + (docs resp) + +renderPlain (DocResult resp) = + printf "%s\nURL: %s\n%s" + (self resp) + (location resp) + (docs resp) + +-- | Render a Hoogle result to HTML. +renderHtml :: HoogleResult -> String +renderHtml (NoResult resp) = + printf "No result: %s" resp + +renderHtml (DocResult resp) = + renderSelf (self resp) (location resp) + ++ + renderDocs (docs resp) + +renderHtml (SearchResult resp) = + renderSelf (self resp) (location resp) + ++ + renderDocs (docs resp) + +renderSelf :: String -> String -> String +renderSelf string loc + | startswith "package" string + = pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string) + + | startswith "module" string + = let package = extractPackageName loc in + mod ++ " " ++ + span "hoogle-module" (link loc $ extractModule string) ++ + packageSub package + + | otherwise + = let [name, args] = split "::" string + package = extractPackageName loc + modname = extractModuleName loc in + span "hoogle-name" (unicodeReplace $ + link loc (strip name) ++ + " :: " ++ + strip args) + ++ packageAndModuleSub package modname + + where + extractPackage = strip . replace "package" "" + extractModule = strip . replace "module" "" + pkg = span "hoogle-head" "package" + mod = span "hoogle-head" "module" + + unicodeReplace :: String -> String + unicodeReplace = + replace "forall" "∀" . + replace "=>" "⇒" . + replace "->" "→" . + replace "::" "∷" + + packageSub Nothing = "" + packageSub (Just package) = + span "hoogle-sub" $ + "(" ++ pkg ++ " " ++ span "hoogle-package" package ++ ")" + + packageAndModuleSub Nothing _ = "" + packageAndModuleSub (Just package) Nothing = packageSub (Just package) + packageAndModuleSub (Just package) (Just modname) = + span "hoogle-sub" $ + "(" ++ pkg ++ " " ++ span "hoogle-package" package ++ + ", " ++ mod ++ " " ++ span "hoogle-module" modname ++ ")" + +renderDocs :: String -> String +renderDocs doc = + let groups = groupBy bothAreCode $ lines doc + nonull = filter (not . null . strip) + bothAreCode s1 s2 = + startswith ">" (strip s1) && + startswith ">" (strip s2) + isCode (s:_) = startswith ">" $ strip s + makeBlock lines = + if isCode lines + then div "hoogle-code" $ unlines $ nonull lines + else div "hoogle-text" $ unlines $ nonull lines + in + div "hoogle-doc" $ unlines $ map makeBlock groups + +extractPackageName :: String -> Maybe String +extractPackageName link = do + let pieces = split "/" link + archiveLoc <- elemIndex "archive" pieces + latestLoc <- elemIndex "latest" pieces + guard $ latestLoc - archiveLoc == 2 + return $ pieces !! (latestLoc - 1) + +extractModuleName :: String -> Maybe String +extractModuleName link = do + let pieces = split "/" link + guard $ not $ null pieces + let html = last pieces + mod = replace "-" "." $ takeWhile (/= '.') html + return mod + +div :: String -> String -> String +div = printf "
%s
" + +span :: String -> String -> String +span = printf "%s" + +link :: String -> String -> String +link = printf "%s" diff --git a/src/IHaskell/Eval/Info.hs b/src/IHaskell/Eval/Info.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Eval/Info.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{- | Description : Inspect type and function information and documentation. +-} +module IHaskell.Eval.Info ( + info + ) where + +import ClassyPrelude hiding (liftIO) + +import IHaskell.Eval.Evaluate (typeCleaner, Interpreter) + +import GHC +import Outputable +import Exception + +info :: String -> Interpreter String +info name = ghandle handler $ do + dflags <- getSessionDynFlags + result <- exprType name + return $ typeCleaner $ showPpr dflags result + where + handler :: SomeException -> Interpreter String + handler _ = return "" diff --git a/src/IHaskell/Eval/Lint.hs b/src/IHaskell/Eval/Lint.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Eval/Lint.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-} +module IHaskell.Eval.Lint ( + lint + ) where + +import Data.String.Utils (replace, startswith, strip, split) +import Prelude (head, tail) +import Language.Haskell.HLint as HLint +import ClassyPrelude +import Control.Monad +import Data.List (findIndex) +import Text.Printf +import Data.String.Here +import Data.Char +import Data.Monoid + +import IHaskell.Types +import IHaskell.Display +import IHaskell.IPython +import IHaskell.Eval.Parser + +data LintSeverity = LintWarning | LintError deriving (Eq, Show) + +data LintSuggestion + = Suggest { + line :: LineNumber, + chunkNumber :: Int, + found :: String, + whyNot :: String, + severity :: LintSeverity, + suggestion :: String + } + deriving (Eq, Show) + +-- | Identifier used when one is needed for proper context. +lintIdent :: String +lintIdent = "lintIdentAEjlkQeh" + +-- | Given parsed code chunks, perform linting and output a displayable +-- report on linting warnings and errors. +lint :: [Located CodeBlock] -> IO Display +lint blocks = do + let validBlocks = map makeValid blocks + fileContents = joinBlocks validBlocks + -- Get a temporarly location to store this file. + ihaskellDir <- getIHaskellDir + let filename = ihaskellDir ++ "/.hlintFile.hs" + + writeFile (fromString filename) fileContents + suggestions <- catMaybes <$> map parseSuggestion <$> hlint [filename, "--quiet"] + return $ + if null suggestions + then Display [] + else Display + [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 + -- correct. + joinBlocks :: [Located String] -> String + joinBlocks = unlines . zipWith addPragma [1 .. ] + + addPragma :: Int -> Located String -> String + addPragma i (Located desiredLine str) = linePragma desiredLine i ++ str + + linePragma = printf "{-# LINE %d \"%d\" #-}\n" + +plainSuggestion :: LintSuggestion -> String +plainSuggestion suggest = + printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s" + (line suggest) + (suggestion suggest) + (found suggest) + (whyNot suggest) + +htmlSuggestions :: [LintSuggestion] -> String +htmlSuggestions = concatMap toHtml + where + toHtml :: LintSuggestion -> String + toHtml suggest = concat + [ + named $ suggestion suggest, + floating "left" $ style severityClass "Found:" ++ + -- Things that look like this get highlighted. + styleId "highlight-code" "haskell" (found suggest), + floating "left" $ style severityClass "Why Not:" ++ + -- Things that look like this get highlighted. + styleId "highlight-code" "haskell" (whyNot suggest) + ] + + where + severityClass = case severity suggest of + LintWarning -> "warning" + LintError -> "error" + + style :: String -> String -> String + style cls thing = [i|
${thing}
|] + + named :: String -> String + named thing = [i|
${thing}
|] + + styleId :: String -> String -> String -> String + styleId cls id thing = [i|
${thing}
|] + + floating :: String -> String -> String + floating dir thing = [i|
${thing}
|] + +-- | Parse a suggestion from Hlint. The suggestions look like this: +-- .ihaskell/.hlintFile.hs:1:19: Warning: Redundant bracket +-- Found: +-- ((3)) +-- Why not: +-- (3) +-- We extract all the necessary fields and store them. +-- If parsing fails, return Nothing. +parseSuggestion :: Suggestion -> Maybe LintSuggestion +parseSuggestion suggestion = do + let str = showSuggestion (show suggestion) + severity = suggestionSeverity suggestion + guard (severity /= HLint.Ignore) + let lintSeverity = case severity of + Warning -> LintWarning + Error -> LintError + + headerLine:foundLine:rest <- Just (lines str) + + -- Expect the line after the header to have 'Found' in it. + guard ("Found:" `isInfixOf` foundLine) + + -- Expect something like: + -- ".hlintFile.hs:1:19: Warning: Redundant bracket" + -- ==> + -- [".hlintFile.hs","1","19"," Warning"," Redundant bracket"] + [readMay -> Just chunkN, + readMay -> Just lineNum, _col, severity, name] <- Just (split ":" headerLine) + + (before, _:after) <- Just (break ("Why not:" `isInfixOf`) rest) + return Suggest { + line = lineNum, + chunkNumber = chunkN, + found = unlines before, + whyNot = unlines after, + suggestion = name, + severity = lintSeverity + } + + +showSuggestion :: String -> String +showSuggestion = + replace ("return " ++ lintIdent) "" . + replace (lintIdent ++ "=") "" . + dropDo + where + + -- 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 [] = [] + +-- | 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 +makeValid (Located line block) = Located line $ + case block of + -- Expressions need to be bound to some identifier. + Expression expr -> lintIdent ++ "=" ++ expr + + -- Statements go in a 'do' block bound to an identifier. + -- + -- a cell can contain: + -- > x <- readFile "foo" + -- so add a return () to avoid a Parse error: Last statement in + -- a do-block must be an expression + -- + -- one place this goes wrong is when the chunk is: + -- + -- > do + -- > {- a comment that has to -} let x = 1 + -- > {- count as whitespace -} y = 2 + -- > return (x+y) + Statement stmt -> + let expandTabs = replace "\t" " " + nLeading = maybe 0 (length . takeWhile isSpace) + $ listToMaybe + $ filter (not . all isSpace) + (lines (expandTabs stmt)) + finalReturn = replicate nLeading ' ' ++ "return " ++ lintIdent + in intercalate ("\n ") ((lintIdent ++ " $ do") : lines stmt ++ [finalReturn]) + + -- Modules, declarations, and type signatures are fine as is. + Module mod -> mod + Declaration decl -> decl + TypeSignature sig -> sig + Import imp -> imp + + -- Output nothing for directives or parse errors. + Directive {} -> "" + ParseError {} -> "" diff --git a/src/IHaskell/Eval/ParseShell.hs b/src/IHaskell/Eval/ParseShell.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Eval/ParseShell.hs @@ -0,0 +1,59 @@ + +-- | This module splits a shell command line into a list of strings, +-- one for each command / filename +module IHaskell.Eval.ParseShell (parseShell) where + +import Prelude hiding (words) +import Text.ParserCombinators.Parsec hiding (manyTill) +import Control.Applicative hiding ((<|>), many, optional) + +eol :: Parser Char +eol = oneOf "\n\r" "end of line" + +quote :: Parser Char +quote = char '\"' + +-- | @manyTill p end@ from hidden @manyTill@ in that it appends the result of @end@ +manyTill :: Parser a -> Parser [a] -> Parser [a] +manyTill p end = scan + where + scan = end <|> do + x <- p + xs <- scan + return $ x:xs + +manyTill1 p end = do x <- p + xs <- manyTill p end + return $ x : xs + +unescapedChar :: Parser Char -> Parser String +unescapedChar p = try $ do + x <- noneOf "\\" + lookAhead p + return [x] + +quotedString = do + quote "expected starting quote" + (manyTill anyChar (unescapedChar quote) <* quote) "unexpected in quoted String " + +unquotedString = manyTill1 anyChar end + where end = unescapedChar space + <|> (lookAhead eol >> return []) + +word = quotedString <|> unquotedString "word" + +separator :: Parser String +separator = many1 space "separator" + +-- | Input must terminate in a space character (like a \n) +words :: Parser [String] +words = try (eof *> return []) <|> do + x <- word + rest1 <- lookAhead (many anyToken) + ss <- separator + rest2 <- lookAhead (many anyToken) + xs <- words + return $ x : xs + +parseShell :: String -> Either ParseError [String] +parseShell string = parse words "shell" (string ++ "\n") diff --git a/src/IHaskell/Eval/Parser.hs b/src/IHaskell/Eval/Parser.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Eval/Parser.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +module IHaskell.Eval.Parser ( + parseString, + CodeBlock(..), + StringLoc(..), + DirectiveType(..), + LineNumber, + ColumnNumber, + ErrMsg, + layoutChunks, + parseDirective, + getModuleName, + unloc, + Located(..), + ) where + +-- Hide 'unlines' to use our own 'joinLines' instead. +import ClassyPrelude hiding (liftIO, unlines) + +import Data.List (findIndex, maximumBy, maximum, inits) +import Data.String.Utils (startswith, strip, split) +import Data.List.Utils (subIndex) +import Prelude (init, last, head, tail) + +import Bag +import ErrUtils hiding (ErrMsg) +import FastString +import GHC hiding (Located) +import Lexer +import OrdList +import Outputable hiding ((<>)) +import SrcLoc hiding (Located) +import StringBuffer + +import Language.Haskell.GHC.Parser +import IHaskell.Eval.Util + +-- | A block of code to be evaluated. +-- Each block contains a single element - one declaration, statement, +-- expression, etc. If parsing of the block failed, the block is instead +-- a ParseError, which has the error location and error message. +data CodeBlock + = Expression String -- ^ A Haskell expression. + | Declaration String -- ^ A data type or function declaration. + | Statement String -- ^ A Haskell statement (as if in a `do` block). + | Import String -- ^ An import statement. + | TypeSignature String -- ^ A lonely type signature (not above a function declaration). + | Directive DirectiveType String -- ^ An IHaskell directive. + | Module String -- ^ A full Haskell module, to be compiled and loaded. + | 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 + = GetType -- ^ Get the type of an expression via ':type' (or unique prefixes) + | GetInfo -- ^ Get info about the identifier via ':info' (or unique prefixes) + | SetDynFlag -- ^ Enable or disable an extensions, packages etc. via `:set`. Emulates GHCi's `:set` + | LoadFile -- ^ Load a Haskell module. + | SetOption -- ^ Set IHaskell kernel option `:option`. + | SetExtension -- ^ `:extension Foo` is a shortcut for `:set -XFoo` + | ShellCmd -- ^ Execute a shell command. + | GetHelp -- ^ General help via ':?' or ':help'. + | SearchHoogle -- ^ Search for something via Hoogle. + | 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 + -- Try to parse this as a single module. + flags <- getSessionDynFlags + let output = runParser flags parserModule codeString + case output of + Parsed {} -> return [Located 1 $ Module codeString] + Failure {} -> do + -- Split input into chunks based on indentation. + let chunks = layoutChunks $ dropComments codeString + result <- joinFunctions <$> processChunks [] chunks + + -- Return to previous flags. When parsing, flags can be set to make + -- sure parsing works properly. But we don't want those flags to be + -- set during evaluation until the right time. + setSessionDynFlags flags + return result + where + parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock) + parseChunk chunk line = Located line <$> + if isDirective chunk + then return $ parseDirective chunk line + else parseCodeChunk chunk line + + processChunks :: GhcMonad m => [Located CodeBlock] -> [Located String] -> m [Located CodeBlock] + processChunks accum remaining = + case remaining of + -- If we have no more remaining lines, return the accumulated results. + [] -> return $ reverse accum + + -- If we have more remaining, parse the current chunk and recurse. + Located line chunk:remaining -> do + block <- parseChunk chunk line + activateParsingExtensions $ unloc block + processChunks (block : accum) remaining + + -- Test wither a given chunk is a directive. + isDirective :: String -> Bool + isDirective = startswith ":" . strip + + -- Number of lines in this string. + nlines :: String -> Int + nlines = length . lines + +activateParsingExtensions :: GhcMonad m => CodeBlock -> m () +activateParsingExtensions (Directive SetExtension ext) = void $ setExtension ext +activateParsingExtensions _ = return () + +-- | Parse a single chunk of code, as indicated by the layout of the code. +parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock +parseCodeChunk code startLine = do + flags <- getSessionDynFlags + let + -- Try each parser in turn. + rawResults = map (tryParser code) (parsers flags) + + -- Convert statements into expressions where we can + results = map (statementToExpression flags) rawResults in + case successes results of + -- If none of them succeeded, choose the best error message to + -- display. Only one of the error messages is actually relevant. + [] -> return $ bestError $ failures results + + -- If one of the parsers succeeded + result:_ -> return result + where + successes :: [ParseOutput a] -> [a] + successes [] = [] + successes (Parsed a:rest) = a : successes rest + successes (_:rest) = successes rest + + failures :: [ParseOutput a] -> [(ErrMsg, LineNumber, ColumnNumber)] + failures [] = [] + failures (Failure msg (Loc line col):rest) = (msg, line, col) : failures rest + failures (_:rest) = failures rest + + bestError :: [(ErrMsg, LineNumber, ColumnNumber)] -> CodeBlock + bestError errors = ParseError (Loc (line + startLine - 1) col) msg + where + (msg, line, col) = maximumBy compareLoc errors + compareLoc (_, line1, col1) (_, line2, col2) = compare line1 line2 <> compare col1 col2 + + statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock + statementToExpression flags (Parsed (Statement stmt)) = Parsed result + where result = if isExpr flags stmt + then Expression stmt + else Statement stmt + statementToExpression _ other = other + + -- Check whether a string is a valid expression. + isExpr :: DynFlags -> String -> Bool + isExpr flags str = case runParser flags parserExpression str of + Parsed {} -> True + _ -> False + + tryParser :: String -> (String -> CodeBlock, String -> ParseOutput String) -> ParseOutput CodeBlock + tryParser string (blockType, parser) = case parser string of + Parsed res -> Parsed (blockType res) + Failure err loc -> Failure err loc + + parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)] + parsers flags = + [ (Import, unparser parserImport) + , (TypeSignature, unparser parserTypeSignature) + , (Declaration, unparser parserDeclaration) + , (Statement, unparser parserStatement) + ] + where + unparser :: Parser a -> String -> ParseOutput String + unparser parser code = + case runParser flags parser code of + Parsed out -> Parsed code + Partial out strs -> Partial code strs + Failure err loc -> Failure err loc + +-- | Find consecutive declarations of the same function and join them into +-- a single declaration. These declarations may also include a type +-- signature, which is also joined with the subsequent declarations. +joinFunctions :: [Located CodeBlock] -> [Located CodeBlock] +joinFunctions (Located line (Declaration decl) : rest) = + -- Find all declarations having the same name as this one. + let (decls, other) = havingSameName rest in + -- Convert them into a single declaration. + Located line (Declaration (joinLines $ map (undecl . unloc) decls)) : joinFunctions other + where + undecl (Declaration decl) = decl + undecl _ = error "Expected declaration!" + + -- Get all declarations with the same name as the first declaration. + -- The name of a declaration is the first word, which we expect to be + -- the name of the function. + havingSameName :: [Located CodeBlock] -> ([Located CodeBlock], [Located CodeBlock]) + havingSameName blocks = + let name = head $ words decl + sameName = takeWhile (isNamedDecl name) rest + others = drop (length sameName) rest in + (Located line (Declaration decl) : sameName, others) + + isNamedDecl :: String -> Located CodeBlock -> Bool + isNamedDecl name (Located _ (Declaration dec)) = head (words dec) == name + isNamedDecl _ _ = False + +-- Allow a type signature followed by declarations to be joined to the +-- declarations. Parse the declaration joining separately. +joinFunctions (Located line (TypeSignature sig) : Located dl (Declaration decl) : rest) = + Located line (Declaration $ sig ++ "\n" ++ joinedDecl):remaining + where Located _ (Declaration joinedDecl):remaining = joinFunctions $ Located dl (Declaration decl) : rest + +joinFunctions (x:xs) = x : joinFunctions xs +joinFunctions [] = [] + + +-- | Parse a directive of the form :directiveName. +parseDirective :: String -- ^ Directive string. + -> Int -- ^ Line number at which the directive appears. + -> CodeBlock -- ^ Directive code block or a parse error. + +parseDirective (':':'!':directive) line = Directive ShellCmd $ '!':directive +parseDirective (':':directive) line = case find rightDirective directives of + Just (directiveType, _) -> Directive directiveType arg + where arg = unwords restLine + _:restLine = words directive + Nothing -> + let directiveStart = case words directive of + [] -> "" + first:_ -> first in + ParseError (Loc line 1) $ "Unknown directive: '" ++ directiveStart ++ "'." + where + rightDirective (_, dirname) = case words directive of + [] -> 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") + ] +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. +getModuleName :: GhcMonad m => String -> m [String] +getModuleName moduleSrc = do + flags <- getSessionDynFlags + let output = runParser flags parserModule moduleSrc + case output of + Failure {} -> error "Module parsing failed." + Parsed mod -> + case unLoc <$> hsmodName (unLoc mod) of + Nothing -> error "Module must have a name." + Just name -> return $ split "." $ moduleNameString name diff --git a/src/IHaskell/Eval/Util.hs b/src/IHaskell/Eval/Util.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Eval/Util.hs @@ -0,0 +1,48 @@ +module IHaskell.Eval.Util ( + extensionFlag, setExtension, + ExtFlag(..), + ) where + +-- GHC imports. +import GHC +import GhcMonad +import DynFlags + +import Data.List (find) + +data ExtFlag + = SetFlag ExtensionFlag + | UnsetFlag ExtensionFlag + +extensionFlag :: String -> Maybe ExtFlag +extensionFlag ext = + case find (flagMatches ext) xFlags of + Just (_, flag, _) -> Just $ SetFlag flag + -- If it doesn't match an extension name, try matching against + -- disabling an extension. + Nothing -> + case find (flagMatchesNo ext) xFlags of + Just (_, flag, _) -> Just $ UnsetFlag flag + Nothing -> Nothing + + where + -- Check if a FlagSpec matches an extension name. + flagMatches ext (name, _, _) = ext == name + + -- Check if a FlagSpec matches "No". + -- In that case, we disable the extension. + flagMatchesNo ext (name, _, _) = ext == "No" ++ name + +-- Set an extension and update flags. +-- Return Nothing on success. On failure, return an error message. +setExtension :: GhcMonad m => String -> m (Maybe String) +setExtension ext = do + flags <- getSessionDynFlags + case extensionFlag ext of + Nothing -> return $ Just $ "Could not parse extension name: " ++ ext + Just flag -> do + setSessionDynFlags $ + case flag of + SetFlag ghcFlag -> xopt_set flags ghcFlag + UnsetFlag ghcFlag -> xopt_unset flags ghcFlag + return Nothing diff --git a/src/IHaskell/Flags.hs b/src/IHaskell/Flags.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Flags.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module IHaskell.Flags ( + IHaskellMode(..), + Argument(..), + Args(..), + parseFlags, + help, + ) where + +import ClassyPrelude +import System.Console.CmdArgs.Explicit +import System.Console.CmdArgs.Text + +import IHaskell.Types + +-- Command line arguments to IHaskell. A set of aruments is annotated with +-- the mode being invoked. +data Args = Args IHaskellMode [Argument] + +data Argument + = ServeFrom String -- ^ Which directory to serve notebooks from. + | Extension String -- ^ An extension to load at startup. + | ConfFile String -- ^ A file with commands to load at startup. + | Help -- ^ Display help text. + deriving (Eq, Show) + +-- Which mode IHaskell is being invoked in. +-- `None` means no mode was specified. +data IHaskellMode + = ShowHelp String + | Notebook + | Console + | UpdateIPython + | Kernel (Maybe String) + | View (Maybe ViewFormat) (Maybe String) + deriving (Eq, Show) + +-- | Given a list of command-line arguments, return the IHaskell mode and +-- arguments to process. +parseFlags :: [String] -> Either String Args +parseFlags = process ihaskellArgs + +-- | Get help text for a given IHaskell ode. +help :: IHaskellMode -> String +help mode = + showText (Wrap 100) $ helpText [] HelpFormatAll $ chooseMode mode + where + chooseMode Console = console + chooseMode Notebook = notebook + chooseMode (Kernel _) = kernel + chooseMode UpdateIPython = update + +universalFlags :: [Flag Args] +universalFlags = [ + flagReq ["extension","e", "X"] (store Extension) "" "Extension to enable at start.", + flagReq ["conf","c"] (store ConfFile) "" "File with commands to execute at start.", + flagHelpSimple (add Help) + ] + where + add flag (Args mode flags) = Args mode $ flag : flags + +store :: (String -> Argument) -> String -> Args -> Either String Args +store constructor str (Args mode prev) = Right $ Args mode $ constructor str : prev + +notebook :: Mode Args +notebook = mode "notebook" (Args Notebook []) "Browser-based notebook interface." noArgs $ + flagReq ["serve","s"] (store ServeFrom) "" "Directory to serve notebooks from.": + universalFlags + +console :: Mode Args +console = mode "console" (Args Console []) "Console-based interactive repl." noArgs universalFlags + +kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg [] + where + kernelArg = flagArg update "" + update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags + +update :: Mode Args +update = mode "update" (Args UpdateIPython []) "Update IPython frontends." noArgs [] + +view :: Mode Args +view = (modeEmpty $ Args (View Nothing Nothing) []) { + modeNames = ["view"], + modeCheck = + \a@(Args (View fmt file) _) -> + if not (isJust fmt && isJust file) + then Left "Syntax: IHaskell view [.ipynb]" + else Right a, + modeHelp = concat [ + "Convert an IHaskell notebook to another format.\n", + "Notebooks are searched in the IHaskell directory and the current directory.\n", + "Available formats are " ++ intercalate ", " (map show + ["pdf", "html", "ipynb", "markdown", "latex"]), + "." + ], + modeArgs = ([formatArg, filenameArg], Nothing) + + } + where + formatArg = flagArg updateFmt "" + filenameArg = flagArg updateFile "[.ipynb]" + updateFmt fmtStr (Args (View _ s) flags) = + case readMay fmtStr of + Just fmt -> Right $ Args (View (Just fmt) s) flags + Nothing -> Left $ "Invalid format '" ++ fmtStr ++ "'." + updateFile name (Args (View f _) flags) = Right $ Args (View f (Just name)) flags + + +ihaskellArgs :: Mode Args +ihaskellArgs = + let descr = "Haskell for Interactive Computing." + helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs + onlyHelp = [flagHelpSimple (add Help)] + noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp in + noMode { modeGroupModes = toGroup [console, notebook, view, update, kernel] } + where + add flag (Args mode flags) = Args mode $ flag : flags + +noArgs = flagArg unexpected "" + where + unexpected a = error $ "Unexpected argument: " ++ a diff --git a/src/IHaskell/IPython.hs b/src/IHaskell/IPython.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/IPython.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE DoAndIfThenElse #-} +-- | Description : Shell scripting wrapper using @Shelly@ for the @notebook@, @setup@, and +-- @console@ commands. +module IHaskell.IPython ( + ipythonInstalled, + installIPython, + updateIPython, + setupIPython, + runConsole, + runNotebook, + readInitInfo, + defaultConfFile, + getIHaskellDir, + getSandboxPackageConf, + nbconvert, + ViewFormat(..), +) where + +import ClassyPrelude +import Prelude (read, reads, init) +import Shelly hiding (find, trace, path, ()) +import System.Argv0 +import System.Directory +import qualified Filesystem.Path.CurrentOS as FS +import Data.List.Utils (split) +import Data.String.Utils (rstrip, endswith) +import Text.Printf + +import qualified System.IO.Strict as StrictIO +import qualified Paths_ihaskell as Paths +import qualified Codec.Archive.Tar as Tar + +import IHaskell.Types + +-- | Which commit of IPython we are on. +ipythonCommit :: Text +ipythonCommit = "9c922f54af799704f4000aeee94ec7c74cada194" + +-- | The IPython profile name. +ipythonProfile :: String +ipythonProfile = "haskell" + +-- | Run IPython with any arguments. +ipython :: Bool -- ^ Whether to suppress output. + -> [Text] -- ^ IPython command line arguments. + -> Sh String -- ^ IPython output. +ipython suppress args = do + ipythonPath <- ipythonExePath + runHandles ipythonPath args handles doNothing + where handles = [InHandle Inherit, outHandle suppress, errorHandle suppress] + outHandle True = OutHandle CreatePipe + outHandle False = OutHandle Inherit + errorHandle True = ErrorHandle CreatePipe + errorHandle False = ErrorHandle Inherit + doNothing _ stdout _ = if suppress + then liftIO $ StrictIO.hGetContents stdout + else return "" + +-- | Run while suppressing all output. +quietRun path args = runHandles path args handles nothing + where + handles = [InHandle Inherit, OutHandle CreatePipe, ErrorHandle CreatePipe] + nothing _ _ _ = return () + +-- | Create the directory and return it. +ensure :: Sh FilePath -> Sh FilePath +ensure getDir = do + dir <- getDir + mkdir_p dir + return dir + +-- | Return the data directory for IHaskell. +ihaskellDir :: Sh FilePath +ihaskellDir = do + home <- maybe (error "$HOME not defined.") fromText <$> get_env "HOME" + ensure $ return (home ".ihaskell") + +ipythonDir :: Sh FilePath +ipythonDir = ensure $ ( "ipython") <$> ihaskellDir + +ipythonExePath :: Sh FilePath +ipythonExePath = ( ("bin" "ipython")) <$> ipythonDir + +notebookDir :: Sh FilePath +notebookDir = ensure $ ( "notebooks") <$> ihaskellDir + +ipythonSourceDir :: Sh FilePath +ipythonSourceDir = ensure $ ( "ipython-src") <$> ihaskellDir + +getIHaskellDir :: IO String +getIHaskellDir = shellyNoDir $ fpToString <$> ihaskellDir + +defaultConfFile :: IO (Maybe String) +defaultConfFile = shellyNoDir $ do + filename <- ( "rc.hs") <$> ihaskellDir + exists <- test_f filename + return $ if exists + then Just $ fpToString filename + else Nothing + +-- | Find a notebook and then convert it into the provided format. +-- Notebooks are searched in the current directory as well as the IHaskell +-- notebook directory (in that order). +nbconvert :: ViewFormat -> String -> IO () +nbconvert fmt name = void . shellyNoDir $ do + curdir <- pwd + nbdir <- notebookDir + -- Find which of the options is available. + let notebookOptions = [ + curdir fpFromString name, + curdir fpFromString (name ++ ".ipynb"), + nbdir fpFromString name, + nbdir fpFromString (name ++ ".ipynb") + ] + maybeNb <- headMay <$> filterM test_f notebookOptions + case maybeNb of + Nothing -> do + putStrLn $ "Cannot find notebook: " ++ pack name + putStrLn "Tried:" + mapM_ (putStrLn . (" " ++) . fpToText) notebookOptions + + Just notebook -> + let viewArgs = case fmt of + Pdf -> ["--to=latex", "--post=pdf"] + Html -> ["--to=html", "--template=ihaskell"] + fmt -> ["--to=" ++ show fmt] in + void $ runIHaskell ipythonProfile "nbconvert" $ viewArgs ++ [fpToString notebook] + +-- | Set up IPython properly. +setupIPython :: IO () +setupIPython = do + installed <- ipythonInstalled + if installed + then updateIPython + else installIPython + + + +-- | Update the IPython source tree and rebuild. +updateIPython :: IO () +updateIPython = void . shellyNoDir $ do + srcDir <- ipythonSourceDir + cd srcDir + gitPath <- path "git" + currentCommitHash <- silently $ pack <$> rstrip <$> unpack <$> run gitPath ["rev-parse", "HEAD"] + when (currentCommitHash /= ipythonCommit) $ do + putStrLn "Incorrect IPython repository commit hash." + putStrLn $ "Found hash: " ++ currentCommitHash + putStrLn $ "Wanted hash: " ++ ipythonCommit + putStrLn "Updating..." + run_ gitPath ["pull", "origin", "master"] + run_ gitPath ["checkout", ipythonCommit] + installPipDependencies + buildIPython + +-- | Install IPython from source. +installIPython :: IO () +installIPython = void . shellyNoDir $ do + installPipDependencies + + -- Get the IPython source. + gitPath <- path "git" + putStrLn "Downloading IPython... (this may take a while)" + ipythonSrcDir <- ipythonSourceDir + run_ gitPath ["clone", "--recursive", "https://github.com/ipython/ipython.git", fpToText ipythonSrcDir] + cd ipythonSrcDir + run_ gitPath ["checkout", ipythonCommit] + + buildIPython + +-- | Install all Python dependencies. +installPipDependencies :: Sh () +installPipDependencies = withTmpDir $ \tmpDir -> + mapM_ (installDependency tmpDir) + [ + ("pyzmq", "14.0.1") + , ("tornado","3.1.1") + , ("jinja2","2.7.1") + -- The following cannot go first in the dependency list, because + -- their setup.py are broken and require the directory to exist + -- already. + , ("MarkupSafe", "0.18") + --, ("setuptools", "2.0.2") + ] + where + installDependency :: FilePath -> (Text, Text) -> Sh () + installDependency tmpDir (dep, version) = sub $ do + let versioned = dep ++ "-" ++ version + putStrLn $ "Installing dependency: " ++ versioned + + pipPath <- path "pip" + tarPath <- path "tar" + pythonPath <- path "python" + + -- Download the package. + let downloadOpt = "--download=" ++ fpToText tmpDir + run_ pipPath ["install", downloadOpt, dep ++ "==" ++ version] + + -- Extract it. + cd tmpDir + run_ tarPath ["-xzf", versioned ++ ".tar.gz"] + + -- Install it. + cd $ fromText versioned + dir <- fpToText <$> ipythonDir + setenv "PYTHONPATH" $ dir ++ "/lib/python2.7/site-packages/" + let prefixOpt = "--prefix=" ++ dir + run_ pythonPath ["setup.py", "install", prefixOpt] + + +-- | Once things are checked out into the IPython source directory, build it and install it. +buildIPython :: Sh () +buildIPython = do + -- Install IPython locally. + pythonPath <- path "python" + prefixOpt <- ("--prefix=" ++) <$> fpToText <$> ipythonDir + putStrLn "Installing IPython." + run_ pythonPath ["setup.py", "install", prefixOpt] + + -- Patch the IPython executable so that it doesn't use system IPython. + -- Using PYTHONPATH is not enough due to bugs in how `easy_install` sets + -- things up, at least on Mac OS X. + ipyDir <- ipythonDir + let patchLines = + [ "#!/usr/bin/env python" + , "import sys" + , "sys.path = [\"" ++ fpToText ipyDir ++ + "/lib/python2.7/site-packages\"] + sys.path"] + ipythonPath <- ipythonExePath + contents <- readFile ipythonPath + writeFile ipythonPath $ unlines patchLines ++ "\n" ++ contents + + -- Remove the old IPython profile so that we write a new one in its + -- place. Users are not expected to fiddle with the profile, so we give + -- no warning whatsoever. This may be changed eventually. + removeIPythonProfile ipythonProfile + + +-- | Check whether IPython is properly installed. +ipythonInstalled :: IO Bool +ipythonInstalled = shellyNoDir $ do + ipythonPath <- ipythonExePath + test_f ipythonPath + +-- | Get the path to an executable. If it doensn't exist, fail with an +-- error message complaining about it. +path :: Text -> Sh FilePath +path exe = do + path <- which $ fromText exe + case path of + Nothing -> do + putStrLn $ "Could not find `" ++ exe ++ "` executable." + fail $ "`" ++ unpack exe ++ "` not on $PATH." + Just exePath -> return exePath + +-- | Use the `ipython --version` command to figure out the version. +-- Return a tuple with (major, minor, patch). +ipythonVersion :: IO (Int, Int, Int) +ipythonVersion = shellyNoDir $ do + [major, minor, patch] <- parseVersion <$> ipython True ["--version"] + return (major, minor, patch) + +-- | Parse an IPython version string into a list of integers. +parseVersion :: String -> [Int] +parseVersion versionStr = map read' $ split "." versionStr + where read' x = case reads x of + [(n, _)] -> n + _ -> error $ "cannot parse version: "++ versionStr + +-- | Run an IHaskell application using the given profile. +runIHaskell :: String -- ^ IHaskell profile name. + -> String -- ^ IPython app name. + -> [String] -- ^ Arguments to IPython. + -> Sh () +runIHaskell profile app args = void $ do + -- Try to locate the profile. Do not die if it doesn't exist. + errExit False $ ipython True ["locate", "profile", pack profile] + + -- If the profile doesn't exist, create it. + -- We have an ugly hack that removes the profile whenever the IPython + -- version is updated. This means profiles get updated with IPython. + exitCode <- lastExitCode + when (exitCode /= 0) $ liftIO $ do + putStrLn "Creating IPython profile." + setupIPythonProfile profile + + -- Run the IHaskell command. + ipython False $ map pack $ [app, "--profile", profile] ++ args + +runConsole :: InitInfo -> IO () +runConsole initInfo = void . shellyNoDir $ do + writeInitInfo initInfo + runIHaskell ipythonProfile "console" [] + +runNotebook :: InitInfo -> Maybe String -> IO () +runNotebook initInfo maybeServeDir = void . shellyNoDir $ do + notebookDirStr <- fpToString <$> notebookDir + let args = case maybeServeDir of + Nothing -> ["--notebook-dir", unpack notebookDirStr] + Just dir -> ["--notebook-dir", dir] + + writeInitInfo initInfo + runIHaskell ipythonProfile "notebook" args + +writeInitInfo :: InitInfo -> Sh () +writeInitInfo info = do + filename <- ( ".last-arguments") <$> ihaskellDir + liftIO $ writeFile filename $ show info + +readInitInfo :: IO InitInfo +readInitInfo = shellyNoDir $ do + filename <- ( ".last-arguments") <$> ihaskellDir + read <$> liftIO (readFile filename) + +-- | Create the IPython profile. +setupIPythonProfile :: String -- ^ IHaskell profile name. + -> IO () +setupIPythonProfile profile = shellyNoDir $ do + -- Create the IPython profile. + void $ ipython True ["profile", "create", pack profile] + + -- Find the IPython profile directory. Make sure to get rid of trailing + -- newlines from the output of the `ipython locate` call. + ipythonDir <- pack <$> rstrip <$> ipython True ["locate"] + let profileDir = ipythonDir ++ "/profile_" ++ pack profile ++ "/" + + liftIO $ copyProfile profileDir + insertIHaskellPath profileDir + +removeIPythonProfile :: String -> Sh () +removeIPythonProfile profile = do + -- Try to locate the profile. Do not die if it doesn't exist. + errExit False $ ipython True ["locate", "profile", pack profile] + + -- If the profile exists, delete it. + exitCode <- lastExitCode + dir <- pack <$> rstrip <$> ipython True ["locate"] + when (exitCode == 0 && dir /= "") $ do + putStrLn "Updating IPython profile." + let profileDir = dir ++ "/profile_" ++ pack profile ++ "/" + rm_rf $ fromText profileDir + +-- | Copy the profile files into the IPython profile. +copyProfile :: Text -> IO () +copyProfile profileDir = do + profileTar <- Paths.getDataFileName "profile/profile.tar" + {- + -- Load profile from Resources directory of Mac *.app. + ihaskellPath <- shellyNoDir getIHaskellPath + profileTar <- if "IHaskell.app/Contents/MacOS" `isInfixOf` ihaskellPath + then + let pieces = split "/" ihaskellPath + pathPieces = init pieces ++ ["..", "Resources", "profile.tar"] in + return $ intercalate "/" pathPieces + else Paths.getDataFileName "profile/profile.tar" + -} + putStrLn $ pack $ "Loading profile from " ++ profileTar + Tar.extract (unpack profileDir) profileTar + +-- | Insert the IHaskell path into the IPython configuration. +insertIHaskellPath :: Text -> Sh () +insertIHaskellPath profileDir = do + path <- getIHaskellPath + let filename = profileDir ++ "ipython_config.py" + template = "exe = '%s'.replace(' ', '\\\\ ')" + exeLine = printf template $ unpack path :: String + + liftIO $ do + contents <- StrictIO.readFile $ unpack filename + writeFile (fromText filename) $ exeLine ++ "\n" ++ contents + +-- | Get the absolute path to this IHaskell executable. +getIHaskellPath :: Sh String +getIHaskellPath = do + -- Get the absolute filepath to the argument. + f <- liftIO getArgv0 + + -- If we have an absolute path, that's the IHaskell we're interested in. + if FS.absolute f + then return $ FS.encodeString f + else + -- Check whether this is a relative path, or just 'IHaskell' with $PATH + -- resolution done by the shell. If it's just 'IHaskell', use the $PATH + -- variable to find where IHaskell lives. + if FS.filename f == f + then do + ihaskellPath <- which "IHaskell" + case ihaskellPath of + Nothing -> error "IHaskell not on $PATH and not referenced relative to directory." + Just path -> return $ FS.encodeString path + else do + -- If it's actually a relative path, make it absolute. + cd <- liftIO getCurrentDirectory + return $ FS.encodeString $ FS.decodeString cd FS. f + +getSandboxPackageConf :: IO (Maybe String) +getSandboxPackageConf = shellyNoDir $ do + myPath <- getIHaskellPath + let sandboxName = ".cabal-sandbox" + if not $ sandboxName`isInfixOf` myPath + then return Nothing + else do + let pieces = split "/" myPath + sandboxDir = intercalate "/" $ takeWhile (/= sandboxName) pieces ++ [sandboxName] + subdirs <- ls $ fpFromString sandboxDir + let confdirs = filter (endswith "packages.conf.d") $ map fpToString subdirs + case confdirs of + [] -> return Nothing + dir:_ -> + return $ Just dir diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Types.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, PatternGuards #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} +-- | Description : All message type definitions. +module IHaskell.Types ( + Message (..), + MessageHeader (..), + MessageType(..), + Username, + Metadata(..), + replyType, + ExecutionState (..), + StreamType(..), + MimeType(..), + DisplayData(..), + EvaluationResult(..), + ExecuteReplyStatus(..), + InitInfo(..), + KernelState(..), + LintStatus(..), + Width, Height, + FrontendType(..), + ViewFormat(..), + Display(..), + defaultKernelState, + extractPlain, + kernelOpts, + KernelOpt(..), + ) where + +import ClassyPrelude +import qualified Data.ByteString.Char8 as Char +import Data.Serialize +import GHC.Generics + +import Text.Read as Read hiding (pfail, String) +import Text.ParserCombinators.ReadP + +import IPython.Kernel + +data ViewFormat + = Pdf + | Html + | Ipynb + | Markdown + | Latex + deriving Eq + +instance Show ViewFormat where + show Pdf = "pdf" + show Html = "html" + show Ipynb = "ipynb" + show Markdown = "markdown" + show Latex = "latex" + +instance Read ViewFormat where + readPrec = Read.lift $ do + str <- munch (const True) + case str of + "pdf" -> return Pdf + "html" -> return Html + "ipynb" -> return Ipynb + "notebook" -> return Ipynb + "latex" -> return Latex + "markdown" -> return Markdown + "md" -> return Markdown + _ -> pfail + +-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple +-- results from the same expression. +data Display = Display [DisplayData] + | ManyDisplay [Display] + deriving (Show, Typeable, Generic) +instance Serialize Display + +instance Monoid Display where + mempty = Display [] + ManyDisplay a `mappend` ManyDisplay b = ManyDisplay (a ++ b) + ManyDisplay a `mappend` b = ManyDisplay (a ++ [b]) + a `mappend` ManyDisplay b = ManyDisplay (a : b) + a `mappend` b = ManyDisplay [a,b] + +-- | All state stored in the kernel between executions. +data KernelState = KernelState + { getExecutionCounter :: Int, + getLintStatus :: LintStatus, -- Whether to use hlint, and what arguments to pass it. + getFrontend :: FrontendType, + useSvg :: Bool, + useShowErrors :: Bool, + useShowTypes :: Bool + } + deriving Show + +defaultKernelState :: KernelState +defaultKernelState = KernelState + { getExecutionCounter = 1, + getLintStatus = LintOn, + getFrontend = IPythonConsole, + useSvg = True, + useShowErrors = False, + useShowTypes = False + } + +data FrontendType + = IPythonConsole + | 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 } + +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 }] + +-- | Initialization information for the kernel. +data InitInfo = InitInfo { + extensions :: [String], -- ^ Extensions to enable at start. + initCells :: [String], -- ^ Code blocks to run before start. + initDir :: String, -- ^ Which directory this kernel should pretend to operate in. + frontend :: FrontendType -- ^ What frontend this serves. + } + deriving (Show, Read) + +-- | Current HLint status. +data LintStatus + = LintOn + | LintOff + deriving (Eq, Show) + + +-- | Output of evaluation. +data EvaluationResult = + -- | An intermediate result which communicates what has been printed thus + -- far. + IntermediateResult { + outputs :: Display -- ^ Display outputs. + } + | FinalResult { + outputs :: Display, -- ^ Display outputs. + pagerOut :: String -- ^ Text to display in the IPython pager. + } diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables #-} +-- | 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 + +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 + +import GHC hiding (extensions, language) +import Outputable (showSDoc, ppr) + +-- | Compute the GHC API version number using the dist/build/autogen/cabal_macros.h +ghcVersionInts :: [Int] +ghcVersionInts = map read . words . map dotToSpace $ VERSION_ghc + where dotToSpace '.' = ' ' + dotToSpace x = x + + +main :: IO () +main = do + args <- parseFlags <$> map unpack <$> getArgs + case args of + Left errorMessage -> + hPutStrLn stderr errorMessage + Right args -> + ihaskell args + +ihaskell :: Args -> IO () +-- If no mode is specified, print help text. +ihaskell (Args (ShowHelp help) _) = + putStrLn $ pack help + +-- Update IPython: remove then reinstall. +-- This is in case cabal updates IHaskell but the corresponding IPython +-- isn't updated. This is hard to detect since versions of IPython might +-- not change! +ihaskell (Args UpdateIPython _) = do + setupIPython + putStrLn "IPython updated." + +ihaskell (Args Console flags) = showingHelp Console flags $ do + setupIPython + + flags <- addDefaultConfFile flags + info <- initInfo IPythonConsole flags + runConsole info + +ihaskell (Args (View (Just fmt) (Just name)) []) = + nbconvert fmt name + +ihaskell (Args Notebook flags) = showingHelp Notebook flags $ do + setupIPython + + let server = case mapMaybe serveDir flags of + [] -> Nothing + xs -> Just $ last xs + + flags <- addDefaultConfFile flags + + undirInfo <- initInfo IPythonNotebook flags + curdir <- getCurrentDirectory + let info = undirInfo { initDir = curdir } + + runNotebook info server + where + serveDir (ServeFrom dir) = Just dir + serveDir _ = Nothing + +ihaskell (Args (Kernel (Just filename)) _) = do + initInfo <- readInitInfo + runKernel filename initInfo + +-- | Add a conf file to the arguments if none exists. +addDefaultConfFile :: [Argument] -> IO [Argument] +addDefaultConfFile flags = do + def <- defaultConfFile + case (find isConfFile flags, def) of + (Nothing, Just file) -> return $ ConfFile file : flags + _ -> return flags + where + isConfFile (ConfFile _) = True + isConfFile _ = False + +showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO () +showingHelp mode flags act = + case find (==Help) flags of + Just _ -> + putStrLn $ pack $ help mode + Nothing -> + act + +-- | Parse initialization information from the flags. +initInfo :: FrontendType -> [Argument] -> IO InitInfo +initInfo front [] = return InitInfo { extensions = [], initCells = [], initDir = ".", frontend = front } +initInfo front (flag:flags) = do + info <- initInfo front flags + case flag of + Extension ext -> return info { extensions = ext:extensions info } + ConfFile filename -> do + cell <- readFile (fpFromText $ pack filename) + return info { initCells = cell:initCells info } + _ -> return info + +-- | Run the IHaskell language kernel. +runKernel :: String -- ^ Filename of profile JSON file. + -> InitInfo -- ^ Initialization information from the invocation. + -> IO () +runKernel profileSrc initInfo = do + setCurrentDirectory $ initDir initInfo + + -- Parse the profile file. + Just profile <- liftM decode . readFile . fpFromText $ pack profileSrc + + -- Necessary for `getLine` and their ilk to work. + dir <- getIHaskellDir + Stdin.recordKernelProfile dir profile + + -- Serve on all sockets and ports defined in the profile. + interface <- serveProfile profile + + -- Create initial state in the directory the kernel *should* be in. + state <- initialKernelState + modifyMVar_ state $ \kernelState -> return $ + kernelState { getFrontend = frontend initInfo } + + -- Receive and reply to all messages on the shell socket. + interpret True $ do + -- Initialize the context by evaluating everything we got from the + -- command line flags. This includes enabling some extensions and also + -- running some code. + let extLines = map (":extension " ++) $ extensions initInfo + noPublish _ = return () + evaluator line = do + -- Create a new state each time. + stateVar <- liftIO initialKernelState + state <- liftIO $ takeMVar stateVar + evaluate state line noPublish + + mapM_ evaluator extLines + mapM_ evaluator $ initCells initInfo + + forever $ do + -- Read the request from the request channel. + request <- liftIO $ readChan $ shellRequestChannel interface + + -- Create a header for the reply. + replyHeader <- createReplyHeader (header request) + + -- Create the reply, possibly modifying kernel state. + oldState <- liftIO $ takeMVar state + (newState, reply) <- replyTo interface request replyHeader oldState + liftIO $ putMVar state newState + + -- Write the reply to the reply channel. + liftIO $ writeChan (shellReplyChannel interface) reply + +-- Initial kernel state. +initialKernelState :: IO (MVar KernelState) +initialKernelState = + newMVar defaultKernelState + +-- | Duplicate a message header, giving it a new UUID and message type. +dupHeader :: MessageHeader -> MessageType -> IO MessageHeader +dupHeader header messageType = do + uuid <- liftIO UUID.random + + return header { messageId = uuid, msgType = messageType } + +-- | Create a new message header, given a parent message header. +createReplyHeader :: MessageHeader -> Interpreter MessageHeader +createReplyHeader parent = do + -- Generate a new message UUID. + newMessageId <- liftIO UUID.random + let repType = fromMaybe err (replyType $ msgType parent) + err = error $ "No reply for message " ++ show (msgType parent) + + return MessageHeader { + identifiers = identifiers parent, + parentHeader = Just parent, + metadata = Map.fromList [], + messageId = newMessageId, + sessionId = sessionId parent, + username = username parent, + msgType = repType + } + +-- | Compute a reply to a message. +replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message) + +-- Reply to kernel info requests with a kernel info reply. No computation +-- needs to be done, as a kernel info reply is a static object (all info is +-- hard coded into the representation of that message type). +replyTo _ KernelInfoRequest{} replyHeader state = + return (state, KernelInfoReply { + header = replyHeader, + language = "haskell", + versionList = ghcVersionInts + }) + +-- Reply to a shutdown request by exiting the main thread. +-- Before shutdown, reply to the request to let the frontend know shutdown +-- is happening. +replyTo interface ShutdownRequest{restartPending = restartPending} replyHeader _ = liftIO $ do + writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending + exitSuccess + +-- Reply to an execution request. The reply itself does not require +-- computation, but this causes messages to be sent to the IOPub socket +-- with the output of the code in the execution request. +replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do + -- Convenience function to send a message to the IOPub socket. + let send msg = liftIO $ writeChan (iopubChannel interface) msg + + -- Log things so that we can use stdin. + dir <- liftIO getIHaskellDir + liftIO $ Stdin.recordParentHeader dir $ header req + + -- Notify the frontend that the kernel is busy computing. + -- All the headers are copies of the reply header with a different + -- message type, because this preserves the session ID, parent header, + -- and other important information. + busyHeader <- liftIO $ dupHeader replyHeader StatusMessage + send $ PublishStatus busyHeader Busy + + -- Construct a function for publishing output as this is going. + -- This function accepts a boolean indicating whether this is the final + -- output and the thing to display. Store the final outputs in a list so + -- that when we receive an updated non-final output, we can clear the + -- entire output and re-display with the updated output. + displayed <- liftIO $ newMVar [] + updateNeeded <- liftIO $ newMVar False + pagerOutput <- liftIO $ newMVar "" + let clearOutput = do + header <- dupHeader replyHeader ClearOutputMessage + send $ ClearOutput header True + + sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts + sendOutput (Display outs) = do + header <- dupHeader replyHeader DisplayDataMessage + send $ PublishDisplayData header "haskell" outs + + publish :: EvaluationResult -> IO () + publish result = do + let final = case result of + IntermediateResult {} -> False + FinalResult {} -> True + outs = outputs result + + -- If necessary, clear all previous output and redraw. + clear <- readMVar updateNeeded + when clear $ do + clearOutput + disps <- readMVar displayed + mapM_ sendOutput $ reverse disps + + -- Draw this message. + sendOutput outs + + -- If this is the final message, add it to the list of completed + -- messages. If it isn't, make sure we clear it later by marking + -- update needed as true. + modifyMVar_ updateNeeded (const $ return $ not final) + when final $ do + modifyMVar_ displayed (return . (outs:)) + + -- If this has some pager output, store it for later. + let pager = pagerOut result + unless (null pager) $ + modifyMVar_ pagerOutput (return . (++ pager ++ "\n")) + + -- Run code and publish to the frontend as we go. + let execCount = getExecutionCounter state + updatedState <- evaluate state (Chars.unpack code) publish + + -- Notify the frontend that we're done computing. + idleHeader <- liftIO $ dupHeader replyHeader StatusMessage + send $ PublishStatus idleHeader Idle + + pager <- liftIO $ readMVar pagerOutput + return (updatedState, ExecuteReply { + header = replyHeader, + pagerOutput = pager, + executionCounter = execCount, + status = Ok + }) + + +replyTo _ req@CompleteRequest{} replyHeader state = do + (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) + +-- | 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) + + +