Commit 9aceb266 authored by Eyal Dechter's avatar Eyal Dechter

Merge remote-tracking branch 'upstream/master' into path_completion

parents ddf3bec9 92262f5f
{-# LANGUAGE ViewPatterns, TypeSynonymInstances, FlexibleInstances #-}
module IHaskell.Display.Magic () where
import IHaskell.Display
import Magic
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as Char
import qualified Data.ByteString.UTF8 as B
import Text.Read
import Data.Char
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.ByteString.UTF8
instance IHaskellDisplay T.Text where
display = display . T.encodeUtf8
instance IHaskellDisplay B.ByteString where
display x = do
m <- magicOpen []
magicLoadDefault m
f <- B.unsafeUseAsCStringLen x (magicCString m)
return [withClass (parseMagic f) x]
b64 :: B.ByteString -> String
b64 = Char.unpack . Base64.encode
withClass :: MagicClass -> B.ByteString -> DisplayData
withClass SVG = svg . B.toString
withClass (PNG w h) = png w h . Base64.encode
withClass JPG = jpg 400 300 . Base64.encode
withClass HTML = html . B.toString
withClass LaTeX = latex . B.toString
withClass _ = plain . B.toString
{- | parse the string produced by magic.
>>> parseMagic "LaTeX 2e document, ASCII text, with very long lines"
LaTeX
>>> parseMagic "PNG image data, 480 x 480, 8-bit/color RGB, non-interlaced"
PNG 480 480
>>> parseMagic "HTML document, ASCII text, with very long lines"
HTML
>>> parseMagic "JPEG image data, JFIF standard 1.01"
JPG
-}
parseMagic :: String -> MagicClass
parseMagic f = case words f of
"SVG" : _ -> SVG
"PNG" : _image : _data :
(readMaybe -> Just w) : _x :
(readMaybe . takeWhile isDigit -> Just h) : _ -> PNG w h
"LaTeX" : _ -> LaTeX
"HTML" : _ -> HTML
"JPEG" : _ -> JPG
_ -> Unknown
data MagicClass =
SVG | PNG Int Int | JPG | HTML | LaTeX | Unknown
deriving Show
The MIT License (MIT)
Copyright (c) 2013 Andrew Gibiansky
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Software, and to permit persons to whom the Software is furnished to do so,
subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
IHaskell-Magic
================
Instances of IHaskellDisplay for `Text` and `ByteString`, where the actual
image or text format is determined using [libmagic](http://packages.debian.org/unstable/libdevel/libmagic-dev), which classifies files according to their contents. It is the same as the shell command `file(1)`. Depending on your OS, you will have to install the c-library first. On a debian-like OS:
```bash
apt-get install libmagic-dev
cd ihaskell-magic
cabal install
```
The instances provided allow displaying images and text with markup using just one line:
```haskell
import qualified Data.ByteString as B
import qualified Data.Text.IO as T
B.readFile "foo.png"
B.readFile "foo.svg"
B.readFile "foo.jpg" -- currently broken (Jan6,2014)
T.readFile "foo.tex" -- doesn't work that well for literal strings,
-- since you pretty much need a \documentclass[]{} to get
-- the file recognized, at which point I'm not sure it renders
T.readFile "foo.html"
```
While you can use `B.readFile "foo.tex"`, that involves more assumptions regarding encodings.
import Distribution.Simple
main = defaultMain
-- Initial ihaskell-display.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
-- The name of the package.
name: ihaskell-magic
-- The package version. See the Haskell package versioning policy (PVP)
-- for standards guiding when and how versions should be incremented.
-- http://www.haskell.org/haskellwiki/Package_versioning_policy
-- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
version: 0.1.0.0
-- A short (one-line) description of the package.
synopsis: IHaskell display instances for bytestrings
-- A longer description of the package.
-- description:
-- URL for the project homepage or repository.
homepage: http://www.github.com/gibiansky/IHaskell
-- The license under which the package is released.
-- license:
-- The file containing the license text.
license-file: LICENSE
-- The package author(s).
author: Adam Vogt
-- An email address to which users can send suggestions, bug reports, and
-- patches.
maintainer: andrew.gibiansky@gmail.com
-- A copyright notice.
-- copyright:
category: Development
build-type: Simple
-- Extra files to be distributed with the package, such as examples or a
-- README.
-- extra-source-files:
-- Constraint on the version of Cabal needed to build this package.
cabal-version: >=1.16
library
-- Modules exported by the library.
exposed-modules: IHaskell.Display.Magic
-- Modules included in this library but not exported.
-- other-modules:
-- Language extensions.
default-extensions: DoAndIfThenElse
OverloadedStrings
-- Other library packages from which modules are imported.
build-depends: base ==4.6.*,
classy-prelude >=0.6,
magic >= 1.0.8,
text,
bytestring,
utf8-string,
base64-bytestring,
ihaskell
-- Directories containing source files.
-- hs-source-dirs:
-- Base language which the package is written in.
default-language: Haskell2010
......@@ -29,7 +29,17 @@ type Base64 = ByteString
class IHaskellDisplay a where
display :: a -> IO [DisplayData]
-- | Display DisplayData values immediately.
-- | these instances cause the image, html etc. which look like:
--
-- > DisplayData
-- > [DisplayData]
-- > IO [DisplayData]
-- > IO (IO DisplayData)
--
-- 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 DisplayData where
display disp = return [disp]
......
......@@ -11,15 +11,19 @@ This has a limited amount of context sensitivity. It distinguishes between four
-}
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 (find, isPrefixOf, nub, findIndex, intercalate, elemIndex)
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 Prelude
import qualified Data.String.Utils as StringUtils
import System.Environment (getEnv)
import GHC
import DynFlags
......@@ -31,10 +35,8 @@ import Outputable (showPpr)
import System.Directory
import System.FilePath
import MonadUtils (MonadIO)
import Control.Monad (filterM, mapM, liftM)
import System.Console.Haskeline.Completion
import qualified Control.Monad.IO.Class as MonadIO (MonadIO(), liftIO)
import IHaskell.Types
import IHaskell.Eval.Evaluate (Interpreter)
......@@ -67,7 +69,7 @@ complete line pos = do
matchedText = intercalate "." target
options <-
case completionType line target of
case completionType line pos target of
Empty -> return []
Identifier candidate ->
......@@ -116,13 +118,22 @@ getTrueModuleName name = do
Nothing -> return name
Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp
completionType :: String -> [String] -> CompletionType
completionType line [] = Empty
completionType line target
| startswith ":! " stripped
= FilePath complete_target
-- | 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
= FilePath lineUpToCursor
| startswith ":l" stripped
= HsFilePath complete_target
= HsFilePath lineUpToCursor
-- 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
......@@ -137,9 +148,7 @@ completionType line target
dots = intercalate "." . init
isModName = all isCapitalized (init target)
isCapitalized = isUpper . head
complete_target = intercalate "." target
lineUpToCursor = take loc line
-- | Get the word under a given cursor location.
completionTarget :: String -> Int -> [String]
......@@ -156,6 +165,7 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
delimPolicy = Drop
}
isDelim :: Char -> Int -> Bool
isDelim char idx = char `elem` neverIdent || isSymbol char
splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]]
......@@ -166,29 +176,66 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
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
completePathFilter :: (String -> Bool) -- ^ filter files
-> (String -> Bool) -- ^ filter directories
-> String -- ^ line contents left of cursor
-> String -- ^ line contents right of cursor
-> Interpreter [String]
completePathFilter fileFilter dirFilter loc roc =
do (_, comps) <- MonadIO.liftIO $ (completeFilename (reverse loc, roc))
let completions = map replacement comps
dirs <- liftIO $ filterM doesDirectoryExist completions
files <- liftIO $ filterM (liftM not . doesDirectoryExist) completions
let dirs' = filter dirFilter files
files' = filter fileFilter dirs
return $ filter (\x -> elem x $ dirs' ++ files') completions
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 loc = completePathFilter (const True) (const True) loc ""
completePath line = completePathFilter acceptAll acceptAll line ""
where acceptAll = const True
completePathWithExtensions :: [String] -> String -> Interpreter [String]
completePathWithExtensions extensions loc =
completePathFilter (\s -> any (\x -> endswith x s) extensions) (const True) loc ""
completePathWithExtensions extensions line =
completePathFilter (extensionIsOneOf extensions) acceptAll line ""
where
acceptAll = const True
extensionIsOneOf exts str = any (str `endswith`) exts
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
......@@ -32,6 +32,7 @@ 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
......@@ -188,19 +189,20 @@ initializeItVariable =
-- | Publisher for IHaskell outputs. The first argument indicates whether
-- this output is final (true) or intermediate (false).
type Publisher = (Bool -> [DisplayData] -> IO ())
type Publisher = (EvaluationResult -> IO ())
-- | Output of a command evaluation.
data EvalOut = EvalOut {
evalStatus :: ErrorOccurred,
evalResult :: [DisplayData],
evalState :: KernelState
evalState :: KernelState,
evalPager :: String
}
-- | Evaluate some IPython input code.
evaluate :: KernelState -- ^ The kernel state.
-> String -- ^ Haskell code or other interpreter commands.
-> Publisher -- ^ Function used to publish data outputs.
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)
......@@ -209,7 +211,7 @@ evaluate kernelState code output = do
when (getLintStatus kernelState /= LintOff) $ liftIO $ do
lintSuggestions <- lint cmds
unless (null lintSuggestions) $
output True lintSuggestions
output $ FinalResult lintSuggestions ""
updated <- runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount])
return updated {
......@@ -223,8 +225,9 @@ evaluate kernelState code output = do
-- Output things only if they are non-empty.
let result = evalResult evalOut
unless (null result) $
liftIO $ output True result
helpStr = evalPager evalOut
unless (null result && null helpStr) $
liftIO $ output $ FinalResult result helpStr
let newState = evalState evalOut
case evalStatus evalOut of
......@@ -233,24 +236,29 @@ evaluate kernelState code output = do
storeItCommand execCount = Statement $ printf "let it%d = it" execCount
wrapExecution :: KernelState
-> Interpreter [DisplayData]
-> Interpreter EvalOut
wrapExecution state exec = ghandle handler $ exec >>= \res ->
return EvalOut {
evalStatus = Success,
evalResult = res,
evalState = state
}
safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut
safely state = ghandle handler
where
handler :: SomeException -> Interpreter EvalOut
handler exception =
return EvalOut {
evalStatus = Failure,
evalResult = displayError $ show exception,
evalState = state
evalState = state,
evalPager = ""
}
wrapExecution :: KernelState
-> Interpreter [DisplayData]
-> Interpreter EvalOut
wrapExecution state exec = safely state $ exec >>= \res ->
return EvalOut {
evalStatus = Success,
evalResult = res,
evalState = state,
evalPager = ""
}
-- | Return the display data for this command, as well as whether it
-- resulted in an error.
evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
......@@ -386,7 +394,8 @@ evalCommand _ (Directive SetOpt option) state = do
return EvalOut {
evalStatus = if isJust newState then Success else Failure,
evalResult = out,
evalState = fromMaybe state newState
evalState = fromMaybe state newState,
evalPager = ""
}
where
......@@ -416,15 +425,21 @@ evalCommand _ (Directive SetOpt option) state = do
evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $ liftIO $
case words cmd of
"cd":dirs ->
let directory = unwords dirs in do
exists <- doesDirectoryExist directory
if exists
then do
setCurrentDirectory directory
return []
else
return $ displayError $ printf "No such directory: '%s'" directory
"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 []
else
return $ displayError $ printf "No such directory: '%s'" directory
cmd -> do
(readEnd, writeEnd) <- createPipe
handle <- fdToHandle writeEnd
......@@ -450,7 +465,7 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
-- Maximum size of the output (after which we truncate).
maxSize = 100 * 1000
incSize = 200
output str = publish False [plain str]
output str = publish $ IntermediateResult [plain str]
loop = do
-- Wait and then check if the computation is done.
......@@ -492,7 +507,8 @@ evalCommand _ (Directive GetHelp _) state = do
return EvalOut {
evalStatus = Success,
evalResult = [out],
evalState = state
evalState = state,
evalPager = ""
}
where out = plain $ intercalate "\n"
["The following commands are available:"
......@@ -512,7 +528,7 @@ evalCommand _ (Directive GetHelp _) state = do
]
-- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand _ (Directive GetInfo str) state = wrapExecution state $ do
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
......@@ -542,11 +558,17 @@ evalCommand _ (Directive GetInfo str) state = wrapExecution state $ do
unqual <- getPrintUnqual
flags <- getSessionDynFlags
let strings = map (showSDocForUser flags unqual) outs
return [plain $ intercalate "\n" strings]
return EvalOut {
evalStatus = Success,
evalResult = [],
evalState = state,
evalPager = unlines strings
}
evalCommand output (Statement stmt) state = wrapExecution state $ do
write $ "Statement:\n" ++ stmt
let outputter str = output False [plain str]
let outputter str = output $ IntermediateResult [plain str]
(printed, result) <- capturedStatement outputter stmt
case result of
RunOk names -> do
......@@ -727,7 +749,8 @@ evalCommand _ (ParseError loc err) state = do
return EvalOut {
evalStatus = Failure,
evalResult = displayError $ formatParseError loc err,
evalState = state
evalState = state,
evalPager = ""
}
-- Read from a file handle until we hit a delimiter or until we've read
......
......@@ -28,10 +28,16 @@ instance ToJSON Message where
"language" .= string "haskell"
]
toJSON ExecuteReply{ status = status, executionCounter = counter} = object [
toJSON ExecuteReply{ status = status, executionCounter = counter, pagerOutput = pager} = object [
"status" .= show status,
"execution_count" .= counter,
"payload" .= emptyList,
"payload" .=
if null pager
then []
else [object [
"source" .= string "page",
"text" .= pager
]],
"user_variables" .= emptyMap,
"user_expressions" .= emptyMap
]
......@@ -61,7 +67,7 @@ instance ToJSON Message where
"matches" .= m,
"matched_text" .= mt,
"text" .= t,
"status" .= if s then "ok" :: String else "error"
"status" .= if s then string "ok" else "error"
]
toJSON o@ObjectInfoReply{} = object [
"oname" .= objectName o,
......
......@@ -14,6 +14,7 @@ module IHaskell.Types (
StreamType(..),
MimeType(..),
DisplayData(..),
EvaluationResult(..),
ExecuteReplyStatus(..),
InitInfo(..),
KernelState(..),
......@@ -220,6 +221,7 @@ data Message
| ExecuteReply {
header :: MessageHeader,
status :: ExecuteReplyStatus, -- ^ The status of the output.
pagerOutput :: String, -- ^ The help string to show in the pager.
executionCounter :: Int -- ^ The execution count, i.e. which output this is.
}
......@@ -358,7 +360,6 @@ extractPlain disps =
where
isPlain (Display mime _) = mime == PlainText
instance Show MimeType where
show PlainText = "text/plain"
show MimeHtml = "text/html"
......@@ -367,6 +368,18 @@ instance Show MimeType where
show MimeSvg = "image/svg+xml"
show MimeLatex = "text/latex"
-- | Output of evaluation.
data EvaluationResult =
-- | An intermediate result which communicates what has been printed thus
-- far.
IntermediateResult {
outputs :: [DisplayData] -- ^ Display outputs.
}
| FinalResult {
outputs :: [DisplayData], -- ^ Display outputs.
pagerOut :: String -- ^ Text to display in the IPython pager.
}
-- | Input and output streams.
data StreamType = Stdin | Stdout deriving Show
......
......@@ -234,7 +234,7 @@ runKernel profileSrc initInfo = do
-- command line flags. This includes enabling some extensions and also
-- running some code.
let extLines = map (":extension " ++) $ extensions initInfo
noPublish _ _ = return ()
noPublish _ = return ()
evaluator line = do
-- Create a new state each time.
stateVar <- liftIO initialKernelState
......@@ -325,8 +325,9 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
-- 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 []
displayed <- liftIO $ newMVar []
updateNeeded <- liftIO $ newMVar False
pagerOutput <- liftIO $ newMVar ""
let clearOutput = do
header <- dupHeader replyHeader ClearOutputMessage
send $ ClearOutput header True
......@@ -335,8 +336,13 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
header <- dupHeader replyHeader DisplayDataMessage
send $ PublishDisplayData header "haskell" outs
publish :: Bool -> [DisplayData] -> IO ()
publish final outputs = do
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
......@@ -345,14 +351,19 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
mapM_ sendOutput $ reverse disps
-- Draw this message.
sendOutput outputs
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 $
modifyMVar_ displayed (return . (outputs:))
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
......@@ -362,8 +373,10 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
idleHeader <- liftIO $ dupHeader replyHeader StatusMessage
send $ PublishStatus idleHeader Idle
pager <- liftIO $ readMVar pagerOutput
return (updatedState, ExecuteReply {
header = replyHeader,
pagerOutput = pager,
executionCounter = execCount,
status = Ok
})
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment