implements ihaskelldisplay typeclass and loading other packages

Haskell-Notebook.ipynb

@@ -24,30 +24,8 @@
      ],
      "language": "python",
      "metadata": {},
-     "outputs": [
-      {
-       "metadata": {},
-       "output_type": "display_data"
-      },
-      {
-       "metadata": {},
-       "output_type": "display_data"
-      },
-      {
-       "metadata": {},
-       "output_type": "display_data",
-       "text": [
-        "X 20\n",
-        "Y \"Test\"\n",
-        "Z 0.5\n"
-       ]
-      },
-      {
-       "metadata": {},
-       "output_type": "display_data"
-      }
-     ],
-     "prompt_number": 1
+     "outputs": [],
+     "prompt_number": "*"
     },
     {
      "cell_type": "code",
@@ -520,7 +498,9 @@
     {
      "cell_type": "code",
      "collapsed": false,
-     "input": [],
+     "input": [
+      "\""
+     ],
      "language": "python",
      "metadata": {},
      "outputs": [

IHaskell.cabal

@@ -64,6 +64,7 @@ library
                        shelly ==1.3.*,
                        system-argv0,
                        directory,
+                       cereal ==0.3.*,
                        here,
                        system-filepath,
                        text ==0.11.*
@@ -71,8 +72,6 @@ library
                    IHaskell.Types,
                    IHaskell.Message.UUID
 
-
-
 executable IHaskell
   -- .hs or .lhs file containing the Main module.
   main-is:             Main.hs
@@ -116,6 +115,7 @@ executable IHaskell
                        directory,
                        here,
                        system-filepath,
+                       cereal ==0.3.*,
                        text ==0.11.*,
                        mtl == 2.1.*,
                        template-haskell

IHaskell/Eval/Evaluate.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-}
 {- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs
                    a statement, declaration, import, or directive.
 
@@ -10,20 +10,29 @@ module IHaskell.Eval.Evaluate (
   ) where
 
 import ClassyPrelude hiding (liftIO, hGetContents)
-import Prelude(putChar, tail, init, (!!))
+import Prelude (putChar, head, tail, 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 Language.Haskell.Exts.Parser hiding (parseType)
+import Language.Haskell.Exts.Parser hiding (parseType, Type)
 import Language.Haskell.Exts.Pretty
-import Language.Haskell.Exts.Syntax hiding (Name)
+import Language.Haskell.Exts.Syntax hiding (Name, Type)
 
 import InteractiveEval
+import DynFlags
+import Type
 import HscTypes
-import GhcMonad (liftIO)
+import HscMain
+import TcType
+import Unify
+import InstEnv
+import GhcMonad (liftIO, withSession)
 import GHC hiding (Stmt, TypeSig)
 import GHC.Paths
 import Exception hiding (evaluate)
@@ -35,8 +44,9 @@ import qualified System.IO.Strict as StrictIO
 
 import IHaskell.Types
 import IHaskell.Eval.Parser
+import IHaskell.Display
 
-data ErrorOccurred = Success | Failure
+data ErrorOccurred = Success | Failure deriving Show
 
 debug :: Bool
 debug = True
@@ -84,20 +94,25 @@ type Interpreter = Ghc
 globalImports :: [String]
 globalImports = 
   [ "import Prelude"
+  -- IHaskell.Display must be imported in order for the IHaskellDisplay
+  -- data typeclass to function properly.
+  --, "import Data.Typeable"
+  , "import qualified Data.Serialize as Serialize"
+  , "import Data.Serialize"
+  , "import IHaskell.Types"
+  , "import IHaskell.Display"
   , "import Control.Applicative ((<$>))"
   , "import GHC.IO.Handle (hDuplicateTo, hDuplicate)"
   , "import System.IO"
   ]
 
-directiveChar :: Char
-directiveChar = ':'
-
 -- | 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
-  dflags <- getSessionDynFlags
+  originalFlags <- getSessionDynFlags
+  let dflags = xopt_set originalFlags Opt_ExtendedDefaultRules
   void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted, ghcLink = LinkInMemory }
 
   -- Load packages that start with ihaskell-* and aren't just IHaskell.
@@ -202,7 +217,73 @@ evalCommand (Statement stmt) = do
 
       return (Failure, [Display MimeHtml $ formatError $ show exception])
 
-evalCommand (Expression expr) = evalCommand (Statement expr)
+evalCommand (Expression expr) = do
+  -- 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 (Statement expr)
+
+  -- If evaluation failed, return the failure.  If it was successful, we
+  -- may be able to use the IHaskellDisplay typeclass.
+  case success of
+    Failure -> return (success, out)
+    Success -> do
+      -- Get the type of the output expression.
+      outType <- exprType "it"
+
+      -- Get all the types that match the IHaskellData typeclass.
+      displayTypes <- getIHaskellDisplayInstances
+
+      flags <- getSessionDynFlags
+      {-
+      liftIO $ print $ (showSDoc flags . ppr) outType
+      liftIO $ print $ map  (showSDoc flags . ppr) displayTypes
+      liftIO $ print $ map (showSDoc flags . ppr . tyVarsOfType) (outType:displayTypes)
+      liftIO $ print $ map (instanceMatches outType) displayTypes 
+      -}
+
+      -- Check if any of the instances match our expression type. 
+      if any (instanceMatches outType) displayTypes 
+      then 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].
+        displayedBytestring <- dynCompileExpr "Serialize.encode (display 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 (success, displayData)
+      else return (success, out)
+
+  where
+    instanceMatches :: Type -> Type -> Bool
+    instanceMatches exprType instanceType =
+      case tcMatchTy (tyVarsOfType instanceType) instanceType exprType of
+        Nothing -> False
+        Just _ -> True
+
+    getIHaskellDisplayInstances :: GhcMonad m => m [Type]
+    getIHaskellDisplayInstances = withSession $ \hscEnv -> do
+      ident <- liftIO $ unLoc <$> hscParseIdentifier hscEnv "IHaskellDisplay"
+      names <- liftIO $ hscTcRnLookupRdrName hscEnv ident
+      case names of
+        [] -> return []
+        [name] -> do
+          maybeThings <- liftIO $ hscTcRnGetInfo hscEnv name
+          case maybeThings of
+            Nothing -> return []
+            -- Just get the first type in the instances, because we know
+            -- that the IHaskellDisplay typeclass only has one type
+            -- argument. Return these types, as these are the ones with
+            -- a match.
+            Just (_, _, instances) -> return $ map (head . is_tys) instances
 
 evalCommand (Declaration decl) = wrapExecution $ runDecls decl >> return []
 

IHaskell/Types.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
 -- | Description : All message type definitions.
 module IHaskell.Types (
   Profile (..),
@@ -20,6 +20,9 @@ module IHaskell.Types (
 import ClassyPrelude
 import Data.Aeson
 import IHaskell.Message.UUID
+import Data.Serialize
+import GHC.Generics (Generic)
+
 
 
 -- | A TCP port.
@@ -273,10 +276,15 @@ instance Show ExecuteReplyStatus where
 data ExecutionState = Busy | Idle | Starting deriving Show
 
 -- | Data for display: a string with associated MIME type.
-data DisplayData = Display MimeType String deriving Show
+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 deriving Eq
+data MimeType = PlainText | MimeHtml deriving (Eq, Typeable, Generic)
+
 
 instance Show MimeType where
   show PlainText = "text/plain"

Main.hs

@@ -147,28 +147,9 @@ replyTo interface ExecuteRequest{ getCode = code } replyHeader state = do
         header <- dupHeader replyHeader DisplayDataMessage
         send $ PublishDisplayData header "haskell" outputs
 
-  -- Get display data outputs of evaluating the code.
+  -- Run code and publish to the frontend as we go.
   evaluate execCount (Chars.unpack code) publish
 
-  {-
-  -- Get display data outputs of evaluating the code.
-  outputs <- evaluate execCount (Chars.unpack code) publish
-
-  -- Find all the plain text outputs.
-  -- Send plain text output via an output message, because we are just
-  -- publishing output and not some representation of data.
-  let isPlain (Display mime _) = mime == PlainText
-  case find isPlain outputs of
-    Just (Display PlainText text) -> do
-      outHeader <- dupHeader replyHeader OutputMessage
-      send $ PublishOutput outHeader text execCount
-    Nothing -> return ()
-
-  -- Send all the non-plain-text representations of data to the frontend.
-  displayHeader <- dupHeader replyHeader DisplayDataMessage
-  send $ PublishDisplayData displayHeader "haskell" $ filter (not . isPlain) outputs
-  -}
-
   -- Notify the frontend that we're done computing.
   idleHeader <- dupHeader replyHeader StatusMessage
   send $ PublishStatus idleHeader Idle