changing DisplayData -> Display in IHaskell

ihaskell-display/ihaskell-aeson/IHaskell/Display/Aeson.hs

@@ -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>|]

ihaskell-display/ihaskell-basic/IHaskell/Display/Display.hs

@@ -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

ihaskell-display/ihaskell-blaze/IHaskell/Display/Blaze.hs

@@ -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

ihaskell-display/ihaskell-charts/IHaskell/Display/Charts.hs

@@ -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

ihaskell-display/ihaskell-diagrams/IHaskell/Display/Diagrams.hs

@@ -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

ihaskell-display/ihaskell-magic/IHaskell/Display/Magic.hs

@@ -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

ipython-kernel/src/IPython/Message/Writer.hs

@@ -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 -----
 

ipython-kernel/src/IPython/Types.hs

@@ -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"

src/IHaskell/Display.hs

@@ -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]
 
-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

src/IHaskell/Eval/Evaluate.hs

@@ -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,11 +519,11 @@ 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,
+                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 =

src/IHaskell/Eval/Lint.hs

@@ -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.

src/IHaskell/Types.hs

@@ -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.
   }

src/Main.hs

@@ -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