mirrors/IHaskell
1
0
Fork 0
mirror of https://github.com/IHaskell/IHaskell.git synced 2025-04-16 11:26:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

changing DisplayData -> Display in IHaskell

Browse Source
This commit is contained in:
Andrew Gibiansky 2014-01-09 18:09:57 -05:00
parent 6b5fb53de4
commit 51b8ea2488
13 changed files with 99 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
ihaskell-display/ihaskell-aeson/IHaskell/Display/Aeson.hs
View File

@ -10,7 +10,7 @@ import Data.String.Here
import IHaskell.Display
instance IHaskellDisplay Value where
display renderable = return [plain json, html dom]
display renderable = return $ Display [plain json, html dom]
where
json = unpack $ decodeUtf8 $ encodePretty renderable
dom = [i|<div class="highlight-code" id="javascript">${json}</div>|]

2
ihaskell-display/ihaskell-basic/IHaskell/Display/Display.hs
View File

@ -6,7 +6,7 @@ import IHaskell.Display
import Text.Printf
instance Show a => IHaskellDisplay (Maybe a) where
display just = return [stringDisplay, htmlDisplay]
display just = return $ Display [stringDisplay, htmlDisplay]
where
stringDisplay = plain (show just)
htmlDisplay = html str

2
ihaskell-display/ihaskell-blaze/IHaskell/Display/Blaze.hs
View File

@ -10,7 +10,7 @@ import Text.Blaze.Internal
import Control.Monad
instance IHaskellDisplay (MarkupM a) where
display val = return [stringDisplay, htmlDisplay]
display val = return $ Display [stringDisplay, htmlDisplay]
where
str = renderMarkup (void val)
stringDisplay = plain str

2
ihaskell-display/ihaskell-charts/IHaskell/Display/Charts.hs
View File

@ -26,7 +26,7 @@ instance IHaskellDisplay (Renderable a) where
-- but SVGs are not resizable in the IPython notebook.
svgDisp <- chartData renderable SVG
return [pngDisp, svgDisp]
return $ Display [pngDisp, svgDisp]
chartData :: Renderable a -> FileFormat -> IO DisplayData
chartData renderable format = do

2
ihaskell-display/ihaskell-diagrams/IHaskell/Display/Diagrams.hs
View File

@ -16,7 +16,7 @@ instance IHaskellDisplay (Diagram Cairo R2) where
display renderable = do
png <- diagramData renderable PNG
svg <- diagramData renderable SVG
return [png, svg]
return $ Display [png, svg]
diagramData :: Diagram Cairo R2 -> OutputType -> IO DisplayData
diagramData renderable format = do

2
ihaskell-display/ihaskell-magic/IHaskell/Display/Magic.hs
View File

@ -24,7 +24,7 @@ instance IHaskellDisplay B.ByteString where
m <- magicOpen []
magicLoadDefault m
f <- B.unsafeUseAsCStringLen x (magicCString m)
return [withClass (parseMagic f) x]
return $ Display [withClass (parseMagic f) x]
b64 :: B.ByteString -> String
b64 = Char.unpack . Base64.encode

2
ipython-kernel/src/IPython/Message/Writer.hs
View File

@ -101,7 +101,7 @@ instance ToJSON StreamType where
-- | Convert a MIME type and value into a JSON dictionary pair.
displayDataToJson :: DisplayData -> (Text, Value)
displayDataToJson (Display mimeType dataStr) = pack (show mimeType) .= dataStr
displayDataToJson (DisplayData mimeType dataStr) = pack (show mimeType) .= dataStr
----- Constants -----

8
ipython-kernel/src/IPython/Types.hs
View File

@ -341,13 +341,13 @@ replyType ShutdownRequestMessage = Just ShutdownReplyMessage
replyType _ = Nothing
-- | Data for display: a string with associated MIME type.
data DisplayData = Display MimeType ByteString deriving (Typeable, Generic)
data DisplayData = DisplayData MimeType ByteString deriving (Typeable, Generic)
-- We can't print the actual data, otherwise this will be printed every
-- time it gets computed because of the way the evaluator is structured.
-- See how `displayExpr` is computed.
instance Show DisplayData where
show _ = "Display"
show _ = "DisplayData"
-- Allow DisplayData serialization
instance Serialize DisplayData
@ -369,9 +369,9 @@ extractPlain :: [DisplayData] -> String
extractPlain disps =
case find isPlain disps of
Nothing -> ""
Just (Display PlainText bytestr) -> Char.unpack bytestr
Just (DisplayData PlainText bytestr) -> Char.unpack bytestr
where
isPlain (Display mime _) = mime == PlainText
isPlain (DisplayData mime _) = mime == PlainText
instance Show MimeType where
show PlainText = "text/plain"

44
src/IHaskell/Display.hs
View File

@ -5,12 +5,13 @@ module IHaskell.Display (
serializeDisplay,
Width, Height, Base64,
encode64, base64,
DisplayData
Display(..),
DisplayData(..),
) where
import ClassyPrelude
import Data.Serialize as Serialize
import Data.ByteString
import Data.ByteString hiding (map)
import Data.String.Utils (rstrip)
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as Char
@ -27,52 +28,59 @@ type Base64 = ByteString
-- > instance (Show a) => IHaskellDisplay a
-- > instance Show a where shows _ = id
class IHaskellDisplay a where
display :: a -> IO [DisplayData]
display :: a -> IO Display
-- | these instances cause the image, html etc. which look like:
--
-- > DisplayData
-- > [DisplayData]
-- > IO [DisplayData]
-- > IO (IO DisplayData)
-- > 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 DisplayData where
display disp = return [disp]
display = (display =<<)
instance IHaskellDisplay [DisplayData] where
instance IHaskellDisplay Display where
display = return
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 = Display PlainText . Char.pack . rstrip
plain = DisplayData PlainText . Char.pack . rstrip
-- | Generate an HTML display.
html :: String -> DisplayData
html = Display MimeHtml . Char.pack
html = DisplayData MimeHtml . Char.pack
-- | Genreate an SVG display.
svg :: String -> DisplayData
svg = Display MimeSvg . Char.pack
svg = DisplayData MimeSvg . Char.pack
-- | Genreate a LaTeX display.
latex :: String -> DisplayData
latex = Display MimeLatex . Char.pack
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 = Display (MimePng width height)
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 = Display (MimeJpg width height)
jpg width height = DisplayData (MimeJpg width height)
-- | Convert from a string into base 64 encoded data.
encode64 :: String -> Base64
@ -84,5 +92,5 @@ base64 = Base64.encode
-- | For internal use within IHaskell.
-- Serialize displays to a ByteString.
serializeDisplay :: [DisplayData] -> ByteString
serializeDisplay :: Display -> ByteString
serializeDisplay = Serialize.encode

87
src/IHaskell/Eval/Evaluate.hs
View File

@ -216,7 +216,7 @@ type Publisher = (EvaluationResult -> IO ())
-- | Output of a command evaluation.
data EvalOut = EvalOut {
evalStatus :: ErrorOccurred,
evalResult :: [DisplayData],
evalResult :: Display,
evalState :: KernelState,
evalPager :: String
}
@ -232,7 +232,7 @@ evaluate kernelState code output = do
when (getLintStatus kernelState /= LintOff) $ liftIO $ do
lintSuggestions <- lint cmds
unless (null lintSuggestions) $
unless (noResults lintSuggestions) $
output $ FinalResult lintSuggestions ""
updated <- runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount])
@ -240,6 +240,9 @@ evaluate kernelState code output = do
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
@ -248,7 +251,7 @@ evaluate kernelState code output = do
-- Output things only if they are non-empty.
let result = evalResult evalOut
helpStr = evalPager evalOut
unless (null result && null helpStr) $
unless (noResults result && null helpStr) $
liftIO $ output $ FinalResult result helpStr
let newState = evalState evalOut
@ -302,7 +305,7 @@ doc sdoc = do
wrapExecution :: KernelState
-> Interpreter [DisplayData]
-> Interpreter Display
-> Interpreter EvalOut
wrapExecution state exec = safely state $ exec >>= \res ->
return EvalOut {
@ -328,7 +331,7 @@ evalCommand _ (Import importStr) state = wrapExecution state $ do
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 []
else Display []
where
implicitImportOf :: ImportDecl RdrName -> InteractiveImport -> Bool
implicitImportOf _ (IIModule _) = False
@ -382,7 +385,7 @@ evalCommand _ (Directive SetExtension exts) state = wrapExecution state $ do
write $ "Extension: " ++ exts
results <- mapM setExtension (words exts)
case catMaybes results of
[] -> return []
[] -> return $ Display []
errors -> return $ displayError $ intercalate "\n" errors
evalCommand _ (Directive GetType expr) state = wrapExecution state $ do
@ -414,7 +417,7 @@ evalCommand _ (Directive SetOpt option) state = do
newState = setOpt opt state
out = case newState of
Nothing -> displayError $ "Unknown option: " ++ opt
Just _ -> []
Just _ -> Display []
return EvalOut {
evalStatus = if isJust newState then Success else Failure,
@ -462,7 +465,7 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
if exists
then do
setCurrentDirectory directory
return []
return $ Display []
else
return $ displayError $ printf "No such directory: '%s'" directory
cmd -> do
@ -490,7 +493,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 $ IntermediateResult [plain str]
output str = publish $ IntermediateResult $ Display [plain str]
loop = do
-- Wait and then check if the computation is done.
@ -516,12 +519,12 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
else do
out <- readMVar outputAccum
case fromJust exitCode of
ExitSuccess -> return [plain out]
ExitSuccess -> return $ Display [plain out]
ExitFailure code -> do
let errMsg = "Process exited with error code " ++ show code
htmlErr = printf "<span class='err-msg'>%s</span>" errMsg
return [plain $ out ++ "\n" ++ errMsg,
html $ printf "<span class='mono'>%s</span>" out ++ htmlErr]
return $ Display [plain $ out ++ "\n" ++ errMsg,
html $ printf "<span class='mono'>%s</span>" out ++ htmlErr]
loop
@ -531,7 +534,7 @@ evalCommand _ (Directive GetHelp _) state = do
write "Help via :help or :?."
return EvalOut {
evalStatus = Success,
evalResult = [out],
evalResult = Display [out],
evalState = state,
evalPager = ""
}
@ -595,7 +598,7 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do
return EvalOut {
evalStatus = Success,
evalResult = [],
evalResult = Display [],
evalState = state,
evalPager = output
}
@ -610,7 +613,7 @@ evalCommand _ (Directive GetDoc query) state = safely state $ do
evalCommand output (Statement stmt) state = wrapExecution state $ do
write $ "Statement:\n" ++ stmt
let outputter str = output $ IntermediateResult [plain str]
let outputter str = output $ IntermediateResult $ Display [plain str]
(printed, result) <- capturedStatement outputter stmt
case result of
RunOk names -> do
@ -628,7 +631,7 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
-- 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 output
then return $ Display output
else do
-- Get all the type strings.
types <- forM nonItNames $ \name -> do
@ -639,11 +642,11 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
htmled = unlines $ map formatGetType types
return $ case extractPlain output of
"" -> [html htmled]
"" -> Display [html htmled]
-- Return plain and html versions.
-- Previously there was only a plain version.
text ->
text -> Display
[plain $ joined ++ "\n" ++ text,
html $ htmled ++ mono text]
@ -654,7 +657,7 @@ evalCommand output (Expression expr) state = do
write $ "Expression:\n" ++ expr
-- Try to use `display` to convert our type into the output
-- DisplayData. If typechecking fails and there is no appropriate
-- 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
@ -686,24 +689,27 @@ evalCommand output (Expression expr) state = do
-- Check if the error is due to trying to print something that doesn't
-- implement the Show typeclass.
isShowError errs =
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
isPlain (Display mime _) = mime == PlainText
isSvg (Display mime _) = mime == MimeSvg
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 [DisplayData]. We also serialize it into a bytestring. We get
-- 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 [DisplayData].
-- refuses to decode back into a Display.
-- Suppress output, so as not to mess up console.
out <- capturedStatement (const $ return ()) displayExpr
@ -713,20 +719,19 @@ evalCommand output (Expression expr) state = do
Just bytestring ->
case Serialize.decode bytestring of
Left err -> error err
Right displayData -> do
write $ show displayData
Right display -> do
return $
if useSvg state
then displayData
else filter (not . isSvg) displayData
then display
else removeSvg display
postprocessShowError :: EvalOut -> EvalOut
postprocessShowError evalOut = evalOut { evalResult = map postprocess disps }
postprocessShowError evalOut = evalOut { evalResult = Display $ map postprocess disps }
where
disps = evalResult evalOut
Display disps = evalResult evalOut
text = extractPlain disps
postprocess (Display MimeHtml _) = html $ printf fmt unshowableType (formatErrorWithClass "err-msg collapse" text) script
postprocess (DisplayData MimeHtml _) = html $ printf fmt unshowableType (formatErrorWithClass "err-msg collapse" text) script
where
fmt = "<div class='collapse-group'><span class='btn' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>"
script = unlines [
@ -763,14 +768,14 @@ evalCommand _ (Declaration decl) state = wrapExecution state $ do
-- 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 []
then return $ Display []
else do
-- Get all the type strings.
types <- forM nonDataNames $ \name -> do
theType <- showSDocUnqual dflags . ppr <$> exprType name
return $ name ++ " :: " ++ theType
return [html $ unlines $ map formatGetType types]
return $ Display [html $ unlines $ map formatGetType types]
evalCommand _ (TypeSignature sig) state = wrapExecution state $
-- We purposefully treat this as a "success" because that way execution
@ -792,7 +797,7 @@ evalCommand _ (ParseError loc err) state = do
hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut
hoogleResults state results = EvalOut {
evalStatus = Success,
evalResult = [],
evalResult = Display [],
evalState = state,
evalPager = output
}
@ -826,7 +831,7 @@ readChars handle delims nchars = do
Left _ -> return []
doLoadModule :: String -> String -> Ghc [DisplayData]
doLoadModule :: String -> String -> Ghc Display
doLoadModule name modName = flip gcatch unload $ do
-- Compile loaded modules.
flags <- getSessionDynFlags
@ -854,10 +859,10 @@ doLoadModule name modName = flip gcatch unload $ do
setSessionDynFlags flags{ hscTarget = HscInterpreted }
case result of
Succeeded -> return []
Succeeded -> return $ Display []
Failed -> return $ displayError $ "Failed to load module " ++ modName
where
unload :: SomeException -> Ghc [DisplayData]
unload :: SomeException -> Ghc Display
unload exception = do
-- Explicitly clear targets
setTargets []
@ -1036,11 +1041,11 @@ formatParseError (Loc line col) =
formatGetType :: String -> String
formatGetType = printf "<span class='get-type'>%s</span>"
formatType :: String -> [DisplayData]
formatType typeStr = [plain typeStr, html $ formatGetType typeStr]
formatType :: String -> Display
formatType typeStr = Display [plain typeStr, html $ formatGetType typeStr]
displayError :: ErrMsg -> [DisplayData]
displayError msg = [plain . fixStdinError . typeCleaner $ msg, html $ formatError msg]
displayError :: ErrMsg -> Display
displayError msg = Display [plain . fixStdinError . typeCleaner $ msg, html $ formatError msg]
fixStdinError :: ErrMsg -> ErrMsg
fixStdinError err =

6
src/IHaskell/Eval/Lint.hs
View File

@ -38,7 +38,7 @@ lintIdent = "lintIdentAEjlkQeh"
-- | Given parsed code chunks, perform linting and output a displayable
-- report on linting warnings and errors.
lint :: [Located CodeBlock] -> IO [DisplayData]
lint :: [Located CodeBlock] -> IO Display
lint blocks = do
let validBlocks = map makeValid blocks
fileContents = joinBlocks validBlocks
@ -50,8 +50,8 @@ lint blocks = do
suggestions <- catMaybes <$> map parseSuggestion <$> hlint [filename, "--quiet"]
return $
if null suggestions
then []
else
then Display []
else Display
[plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]
where
-- Join together multiple valid file blocks into a single file.

13
src/IHaskell/Types.hs
View File

@ -20,12 +20,15 @@ module IHaskell.Types (
Width, Height,
FrontendType(..),
ViewFormat(..),
Display(..),
defaultKernelState,
extractPlain
) 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
@ -60,6 +63,12 @@ instance Read ViewFormat where
"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
-- | All state stored in the kernel between executions.
data KernelState = KernelState
@ -108,9 +117,9 @@ data EvaluationResult =
-- | An intermediate result which communicates what has been printed thus
-- far.
IntermediateResult {
outputs :: [DisplayData] -- ^ Display outputs.
outputs :: Display -- ^ Display outputs.
}
| FinalResult {
outputs :: [DisplayData], -- ^ Display outputs.
outputs :: Display, -- ^ Display outputs.
pagerOut :: String -- ^ Text to display in the IPython pager.
}

3
src/Main.hs
View File

@ -252,7 +252,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
header <- dupHeader replyHeader ClearOutputMessage
send $ ClearOutput header True
sendOutput outs = do
sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts
sendOutput (Display outs) = do
header <- dupHeader replyHeader DisplayDataMessage
send $ PublishDisplayData header "haskell" outs