Updated to ClassyPrelude. Fixed UUID issues.

.gitignore

@@ -0,0 +1,4 @@
+*.hi
+*.o
+dist
+env

IHaskell.cabal

@@ -62,6 +62,7 @@ executable IHaskell
                        aeson ==0.6.*,
                        MissingH ==1.2.*,
                        basic-prelude ==0.3.*,
+                       classy-prelude ==0.6.*,
                        unix ==2.6.*,
                        bytestring ==0.10.*,
                        transformers ==0.3.*,

IHaskell/Message/BodyParser.hs

@@ -1,46 +0,0 @@
--- | This module provides parsers for message bodies for
--- @IHaskell.Message.Parser@, and should not be used elsewhere. The
--- 'header' field on all these messages is initialized to 'undefined' and
--- is inserted afterwards.
-module IHaskell.Message.BodyParser (
-  kernelInfoRequestParser,
-  executeRequestParser
-)  where
-
-import BasicPrelude
-import Data.Aeson
-import Data.Aeson.Types (parse)
-
-import IHaskell.Types
-
--- | Parse a kernel info request.
--- A kernel info request has no auxiliary information, so ignore the body.
-kernelInfoRequestParser :: LByteString -> Message
-kernelInfoRequestParser _ = KernelInfoRequest { header = undefined }
-
--- | 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 = undefined,
-      getCode = code,
-      getSilent = silent,
-      getAllowStdin = allowStdin,
-      getStoreHistory = storeHistory,
-      getUserVariables = [],
-      getUserExpressions = []
-    }

IHaskell/Message/Parser.hs

@@ -3,34 +3,28 @@
 -- | `parseMessage`, which should only be used in the low-level 0MQ interface.
 module IHaskell.Message.Parser (parseMessage) where
 
-import BasicPrelude
+import ClassyPrelude
 import Data.Aeson ((.:), decode, Result(..), Object)
 import Data.Aeson.Types (parse)
 
 import qualified Data.ByteString.Lazy as Lazy
 
 import IHaskell.Types
-import IHaskell.Message.BodyParser
-
-import Debug.Trace
-
-debug x = trace (textToString $ show x) x
 
 ----- 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.
+              -> 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 in
-    (parser messageType $ Lazy.fromStrict content) {
-      header = header                      
-    }
+      messageType = msgType header
+      messageWithoutHeader = parser messageType $ Lazy.fromStrict content in
+    messageWithoutHeader { header = header }
 
 ----- Module internals -----
 
@@ -51,26 +45,61 @@ parseHeader idents headerData parentHeader metadata = MessageHeader {
   } 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 = debug $ decode $ Lazy.fromStrict headerData :: Maybe Object
+      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) = debug $ flip parse result $ \obj -> do 
+      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 (debug messType, debug username, debug message, debug 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.
+       -> LByteString -> Message   -- The parser that converts the body into a message.
+                                 -- This message should have an undefined
+                                 -- header.
 parser "kernel_info_request"  = kernelInfoRequestParser
 parser "execute_request"      = executeRequestParser
-parser other = error $ "Unknown message type " ++ textToString (show other)
+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 = []
+    }

IHaskell/Message/UUID.hs

@@ -0,0 +1,42 @@
+-- | 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 an infinite list of random UUIDs.
+randoms :: Int -> 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

IHaskell/Message/Writer.hs

@@ -3,9 +3,8 @@ module IHaskell.Message.Writer (
   ToJSON(..)
 )  where
 
-import BasicPrelude
+import ClassyPrelude
 import Data.Aeson
-import Data.Map (fromList)
 
 import IHaskell.Types
 
@@ -34,8 +33,9 @@ instance ToJSON Message where
   toJSON IopubDisplayData{ source = src, displayData = datas } = object [
                              "source" .= src,
                              "metadata" .= object [],
-                             "data" .= object  (map (uncurry displayDataToJson) datas)
+                             "data" .= object  (map displayDataToJson datas)
                            ]
+
   toJSON IopubPythonOut{ executionCount = execCount, reprText = reprText } = object [
                              "data" .= object ["text/plain" .= reprText, 
                                                "text/html" .= reprText],
@@ -47,23 +47,28 @@ instance ToJSON Message where
                              "code" .= code
                            ]
 
-  toJSON body = error $ "Do not know how to convert to JSON for message " ++ textToString (show body)
+  toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body
 
-displayDataToJson mimeType dataStr = (show mimeType .= dataStr)
 
+-- | 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 = fromList []
+emptyMap = mempty
 
 emptyList :: [Int]
 emptyList = []

IHaskell/Types.hs

@@ -10,47 +10,13 @@ module IHaskell.Types (
   ExecutionState (..),
   StreamType(..),
   MimeType(..),
+  DisplayData(..),
   ) where
 
-import BasicPrelude
+import ClassyPrelude
 import Data.Aeson
-import Data.UUID (UUID)
-import Data.ByteString.Char8 (unpack)
-import Data.Char (toUpper)
+import IHaskell.Message.UUID
 
-import qualified Data.UUID as UUID (fromString, toString)
-
--- Allows reading and writing UUIDs as Strings in JSON. 
-instance FromJSON UUID where
-  parseJSON val@(String _) = do
-    -- Parse the string into a String.
-    str <- parseJSON val
-
-    -- If there are no hyphens, insert them.
-    -- This is an issue with IPython notebook.
-    let hyphenated = if '-' `notElem` str
-                     then hyphenate str
-                     else str
-
-    -- Attempt to parse string into UUID.
-    case UUID.fromString hyphenated of
-      Nothing -> fail $ "Could not parse UUID from " ++ hyphenated
-      Just uuid -> return uuid
-
-    where
-      hyphenate str = concat [one, "-", two, "-", three, "-", four, "-", restFour]
-        where
-          (one, restOne) = splitAt 8 str
-          (two, restTwo) = splitAt 4 restOne
-          (three, restThree) = splitAt 4 restTwo
-          (four, restFour) = splitAt 4 restThree
-
-  -- UUIDs must be Strings.
-  parseJSON _ = mzero
-
-instance ToJSON UUID where
-  -- Convert a UUID to [Char] and then to Text.
-  toJSON = String . fromString . map toUpper . filter (/= '-') . UUID.toString
 
 -- | A TCP port.
 type Port = Int
@@ -158,7 +124,7 @@ data Message
   | IopubDisplayData {
       header :: MessageHeader,
       source :: String,
-      displayData :: [(MimeType, String)]
+      displayData :: [DisplayData]
     }
 
   | IopubPythonOut {
@@ -180,9 +146,12 @@ data ExecutionState = Busy | Idle | Starting deriving Show
 -- | Possible MIME types for the display data.
 data MimeType = PlainText | MimeHtml
 
+-- | Data for display: a string with associated MIME type.
+data DisplayData = Display MimeType String deriving Show
+
 instance Show MimeType where
-  showsPrec prec PlainText str = str ++ "text/plain"
-  showsPrec prec MimeHtml str = str ++ "text/html"
+  show PlainText = "text/plain"
+  show MimeHtml  = "text/html"
 
 -- | Input and output streams.
 data StreamType = Stdin | Stdout deriving Show
@@ -191,4 +160,4 @@ data StreamType = Stdin | Stdout deriving Show
 replyType :: MessageType -> MessageType
 replyType "kernel_info_request" = "kernel_info_reply"
 replyType "execute_request" = "execute_reply"
-replyType messageType = error $ "Unknown message type " ++ unpack messageType
+replyType messageType = error $ "Unknown message type " ++ show messageType

IHaskell/ZeroMQ.hs

@@ -119,7 +119,7 @@ iopub channels socket =
 
 stdin :: ZeroMQInterface -> Socket Router -> IO ()
 stdin _ socket = do
-  next <- receive socket
+  void $ receive socket
   return ()
 
 -- | Receive and parse a message from a socket.

Main.hs

@@ -1,13 +1,12 @@
-import BasicPrelude
-import Control.Concurrent
+import ClassyPrelude
+import Control.Concurrent.Chan
 import Data.Aeson
 
 import qualified Data.Map as Map
-import qualified Data.UUID.V4 as UUID (nextRandom)
-import qualified Data.ByteString.Lazy as ByteString
 
 import IHaskell.Types
 import IHaskell.ZeroMQ
+import qualified IHaskell.Message.UUID as UUID
 
 data KernelState = KernelState
   { getExecutionCounter :: Int
@@ -19,7 +18,7 @@ main = do
   [profileSrc] <- getArgs
 
   -- Parse the profile file.
-  Just profile <- liftM decode $ ByteString.readFile (textToString profileSrc)
+  Just profile <- liftM decode $ readFile $ fpFromText profileSrc
 
   -- Serve on all sockets and ports defined in the profile.
   interface <- serveProfile profile
@@ -50,7 +49,7 @@ initialKernelState = newMVar KernelState {
 createReplyHeader :: MessageHeader -> IO MessageHeader
 createReplyHeader parent = do
   -- Generate a new message UUID.
-  newMessageId <- UUID.nextRandom
+  newMessageId <- UUID.random
 
   return MessageHeader {
     identifiers = identifiers parent,
@@ -67,23 +66,18 @@ replyTo _ KernelInfoRequest{} replyHeader state = return (state, KernelInfoReply
 
 replyTo interface ExecuteRequest{} replyHeader state = do
   -- Queue up a response on the iopub socket 
-  newMessageId <- UUID.nextRandom
-  newMessageId2 <- UUID.nextRandom
-  newMessageId3 <- UUID.nextRandom
-  newMessageId4 <- UUID.nextRandom
-  newMessageId5 <- UUID.nextRandom
-  newMessageId6 <- UUID.nextRandom
+  uuid1 : uuid2 : uuid3 : uuid4 : uuid5 : uuid6 : []   <- UUID.randoms 6
 
   let header =  MessageHeader {
     identifiers = identifiers replyHeader,
     parentHeader = parentHeader replyHeader,
     metadata = Map.fromList [],
-    messageId = newMessageId,
+    messageId = uuid1,
     sessionId = sessionId replyHeader,
     username = username replyHeader,
     msgType = "status"
   }
-  let busyHeader = header { messageId = newMessageId5 }
+  let busyHeader = header { messageId = uuid5 }
   let statusMsg = IopubStatus {
     header = header,
     executionState = Idle
@@ -96,7 +90,7 @@ replyTo interface ExecuteRequest{} replyHeader state = do
     identifiers = identifiers replyHeader,
     parentHeader = parentHeader replyHeader,
     metadata = Map.fromList [],
-    messageId = newMessageId2,
+    messageId = uuid2,
     sessionId = sessionId replyHeader,
     username = username replyHeader,
     msgType = "stream"
@@ -105,18 +99,18 @@ replyTo interface ExecuteRequest{} replyHeader state = do
     identifiers = identifiers replyHeader,
     parentHeader = parentHeader replyHeader,
     metadata = Map.fromList [],
-    messageId = newMessageId3,
+    messageId = uuid3,
     sessionId = sessionId replyHeader,
     username = username replyHeader,
     msgType = "display_data"
   }
-  let pyoutHeader = dispHeader { messageId = newMessageId4, msgType = "pyout" }
-  let pyinHeader = dispHeader { messageId = newMessageId6, msgType = "pyin" }
+  let pyoutHeader = dispHeader { messageId = uuid4, msgType = "pyout" }
+  let pyinHeader = dispHeader { messageId = uuid6, msgType = "pyin" }
 
-  let things = textToString "$a+b=c$"
-  let streamMsg = IopubStream streamHeader Stdout $ textToString $ "Hello! " ++ show (getExecutionCounter state)
-  let displayMsg = IopubDisplayData dispHeader "haskell" [(PlainText, things), (MimeHtml, things)]
-      pyoutMsg = IopubPythonOut pyoutHeader ("Iopub python out " ++ textToString (show (getExecutionCounter state))) (getExecutionCounter state)
+  let things = "$a+b=c$"
+  let streamMsg = IopubStream streamHeader Stdout $ "Hello! " ++ show (getExecutionCounter state)
+  let displayMsg = IopubDisplayData dispHeader "haskell" [Display PlainText things, Display MimeHtml things]
+      pyoutMsg = IopubPythonOut pyoutHeader ("Iopub python out " ++ (show (getExecutionCounter state))) (getExecutionCounter state)
       pyinMsg = IopubPythonIn pyinHeader "Who the fuck cares?!" (getExecutionCounter state)
   mapM_ (writeChan $ iopubChannel interface) [pyinMsg, busyMsg, displayMsg, pyoutMsg, statusMsg]