{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}

-- | Description : All message type definitions.
module IHaskell.Types (
    Message(..),
    MessageHeader(..),
    MessageType(..),
    dupHeader,
    setVersion,
    Username,
    Metadata,
    BufferPath,
    replyType,
    ExecutionState(..),
    StreamType(..),
    MimeType(..),
    DisplayData(..),
    ErrorOccurred(..),
    EvaluationResult(..),
    evaluationOutputs,
    ExecuteReplyStatus(..),
    KernelState(..),
    LintStatus(..),
    Width,
    Height,
    Display(..),
    defaultKernelState,
    extractPlain,
    kernelOpts,
    KernelOpt(..),
    IHaskellDisplay(..),
    IHaskellWidget(..),
    Widget(..),
    WidgetMsg(..),
    WidgetMethod(..),
    KernelSpec(..),
    ) where

import           IHaskellPrelude

import           Data.Aeson (ToJSON (..), Value, (.=), object, Value(String))
import           Data.Function (on)
import           Data.Text (pack)
import           Data.Binary
import           GHC.Generics

import           IHaskell.IPython.Kernel

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KeyMap
#else
import qualified Data.HashMap.Strict as HashMap
#endif

-- | A class for displayable Haskell types.
--
-- IHaskell's displaying of results behaves as if these two overlapping/undecidable instances also
-- existed:
--
-- > instance (Show a) => IHaskellDisplay a
-- > instance Show a where shows _ = id
class IHaskellDisplay a where
  display :: a -> IO Display

type BufferPath = [Text]

emptyBPs :: [BufferPath]
emptyBPs :: [BufferPath]
emptyBPs = []

-- | Display as an interactive widget.
class IHaskellDisplay a => IHaskellWidget a where
  -- | Target name for this widget. The actual input parameter should be ignored. By default evaluate
  -- to "jupyter.widget", which is used by IPython for its backbone widgets.
  targetName :: a -> String
  targetName a
_ = String
"jupyter.widget"

  -- | Target module for this widget. Evaluates to an empty string by default.
  targetModule :: a -> String
  targetModule a
_ = String
""

  -- | Buffer paths for this widget. Evaluates to an empty array by default.
  getBufferPaths :: a -> [BufferPath]
  getBufferPaths a
_ = [BufferPath]
emptyBPs

  -- | Get the uuid for comm associated with this widget. The widget is responsible for storing the
  -- UUID during initialization.
  getCommUUID :: a -> UUID

  -- | Called when the comm is opened. Allows additional messages to be sent after comm open.
  open :: a                -- ^ Widget to open a comm port with.
       -> (Value -> IO ()) -- ^ A function for sending messages.
       -> IO ()
  open a
_ Value -> IO ()
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- | Respond to a comm data message. Called when a message is recieved on the comm associated with
  -- the widget.
  comm :: a                -- ^ Widget which is being communicated with.
       -> Value            -- ^ Data recieved from the frontend.
       -> (Value -> IO ()) -- ^ Way to respond to the message.
       -> IO ()
  comm a
_ Value
_ Value -> IO ()
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- | Called when a comm_close is recieved from the frontend.
  close :: a               -- ^ Widget to close comm port with.
        -> Value           -- ^ Data recieved from the frontend.
        -> IO ()
  close a
_ Value
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | these instances cause the image, html etc. which look like:
--
-- > 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 :: IO a -> IO Display
display = (a -> IO Display
forall a. IHaskellDisplay a => a -> IO Display
display (a -> IO Display) -> IO a -> IO Display
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)

instance IHaskellDisplay Display where
  display :: Display -> IO Display
display = Display -> IO Display
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance IHaskellDisplay DisplayData where
  display :: DisplayData -> IO Display
display DisplayData
disp = Display -> IO Display
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> IO Display) -> Display -> IO Display
forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display [DisplayData
disp]

instance IHaskellDisplay a => IHaskellDisplay [a] where
  display :: [a] -> IO Display
display [a]
disps = do
    [Display]
displays <- (a -> IO Display) -> [a] -> IO [Display]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> IO Display
forall a. IHaskellDisplay a => a -> IO Display
display [a]
disps
    Display -> IO Display
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Display -> IO Display) -> Display -> IO Display
forall a b. (a -> b) -> a -> b
$ [Display] -> Display
ManyDisplay [Display]
displays

data Widget = forall a. IHaskellWidget a => Widget a
  deriving Typeable

instance IHaskellDisplay Widget where
  display :: Widget -> IO Display
display (Widget a
widget) = a -> IO Display
forall a. IHaskellDisplay a => a -> IO Display
display a
widget

instance IHaskellWidget Widget where
  targetName :: Widget -> String
targetName (Widget a
widget) = a -> String
forall a. IHaskellWidget a => a -> String
targetName a
widget
  targetModule :: Widget -> String
targetModule (Widget a
widget) = a -> String
forall a. IHaskellWidget a => a -> String
targetModule a
widget
  getBufferPaths :: Widget -> [BufferPath]
getBufferPaths (Widget a
widget) = a -> [BufferPath]
forall a. IHaskellWidget a => a -> [BufferPath]
getBufferPaths a
widget
  getCommUUID :: Widget -> UUID
getCommUUID (Widget a
widget) = a -> UUID
forall a. IHaskellWidget a => a -> UUID
getCommUUID a
widget
  open :: Widget -> (Value -> IO ()) -> IO ()
open (Widget a
widget) = a -> (Value -> IO ()) -> IO ()
forall a. IHaskellWidget a => a -> (Value -> IO ()) -> IO ()
open a
widget
  comm :: Widget -> Value -> (Value -> IO ()) -> IO ()
comm (Widget a
widget) = a -> Value -> (Value -> IO ()) -> IO ()
forall a.
IHaskellWidget a =>
a -> Value -> (Value -> IO ()) -> IO ()
comm a
widget
  close :: Widget -> Value -> IO ()
close (Widget a
widget) = a -> Value -> IO ()
forall a. IHaskellWidget a => a -> Value -> IO ()
close a
widget

instance Show Widget where
  show :: Widget -> String
show Widget
_ = String
"<Widget>"

instance Eq Widget where
  == :: Widget -> Widget -> Bool
(==) = UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
(==) (UUID -> UUID -> Bool)
-> (Widget -> UUID) -> Widget -> Widget -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Widget -> UUID
forall a. IHaskellWidget a => a -> UUID
getCommUUID

-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple results from the same
-- expression.
data Display = Display [DisplayData]
             | ManyDisplay [Display]
  deriving (Int -> Display -> ShowS
[Display] -> ShowS
Display -> String
(Int -> Display -> ShowS)
-> (Display -> String) -> ([Display] -> ShowS) -> Show Display
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Display -> ShowS
showsPrec :: Int -> Display -> ShowS
$cshow :: Display -> String
show :: Display -> String
$cshowList :: [Display] -> ShowS
showList :: [Display] -> ShowS
Show, Display -> Display -> Bool
(Display -> Display -> Bool)
-> (Display -> Display -> Bool) -> Eq Display
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Display -> Display -> Bool
== :: Display -> Display -> Bool
$c/= :: Display -> Display -> Bool
/= :: Display -> Display -> Bool
Eq, Typeable, (forall x. Display -> Rep Display x)
-> (forall x. Rep Display x -> Display) -> Generic Display
forall x. Rep Display x -> Display
forall x. Display -> Rep Display x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Display -> Rep Display x
from :: forall x. Display -> Rep Display x
$cto :: forall x. Rep Display x -> Display
to :: forall x. Rep Display x -> Display
Generic)

instance ToJSON Display where
  toJSON :: Display -> Value
toJSON (Display [DisplayData]
d) = [Pair] -> Value
object ((DisplayData -> Pair) -> [DisplayData] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map DisplayData -> Pair
displayDataToJson [DisplayData]
d)
  toJSON (ManyDisplay [Display]
d) = [Display] -> Value
forall a. ToJSON a => a -> Value
toJSON [Display]
d

instance Binary Display

instance Semigroup Display where
  ManyDisplay [Display]
a <> :: Display -> Display -> Display
<> ManyDisplay [Display]
b = [Display] -> Display
ManyDisplay ([Display]
a [Display] -> [Display] -> [Display]
forall a. [a] -> [a] -> [a]
++ [Display]
b)
  ManyDisplay [Display]
a <> Display
b = [Display] -> Display
ManyDisplay ([Display]
a [Display] -> [Display] -> [Display]
forall a. [a] -> [a] -> [a]
++ [Display
b])
  Display
a <> ManyDisplay [Display]
b = [Display] -> Display
ManyDisplay (Display
a Display -> [Display] -> [Display]
forall a. a -> [a] -> [a]
: [Display]
b)
  Display
a <> Display
b = [Display] -> Display
ManyDisplay [Display
a, Display
b]

instance Monoid Display where
  mempty :: Display
mempty = [DisplayData] -> Display
Display []
  mappend :: Display -> Display -> Display
mappend = Display -> Display -> Display
forall a. Semigroup a => a -> a -> a
(<>)

-- | All state stored in the kernel between executions.
data KernelState =
       KernelState
         { KernelState -> Int
getExecutionCounter :: Int
         , KernelState -> LintStatus
getLintStatus :: LintStatus   -- Whether to use hlint, and what arguments to pass it.
         , KernelState -> Bool
useSvg :: Bool
         , KernelState -> Bool
useShowErrors :: Bool
         , KernelState -> Bool
useShowTypes :: Bool
         , KernelState -> Bool
usePager :: Bool
         , KernelState -> Map UUID Widget
openComms :: Map UUID Widget
         , KernelState -> Bool
kernelDebug :: Bool
         , KernelState -> Bool
supportLibrariesAvailable :: Bool
         , KernelState -> Maybe String
htmlCodeWrapperClass :: Maybe String -- ^ HTML output: class name for wrapper div
         , KernelState -> String
htmlCodeTokenPrefix :: String        -- ^ HTML output: class name prefix for token spans
         }
  deriving Int -> KernelState -> ShowS
[KernelState] -> ShowS
KernelState -> String
(Int -> KernelState -> ShowS)
-> (KernelState -> String)
-> ([KernelState] -> ShowS)
-> Show KernelState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KernelState -> ShowS
showsPrec :: Int -> KernelState -> ShowS
$cshow :: KernelState -> String
show :: KernelState -> String
$cshowList :: [KernelState] -> ShowS
showList :: [KernelState] -> ShowS
Show

defaultKernelState :: KernelState
defaultKernelState :: KernelState
defaultKernelState = KernelState
  { getExecutionCounter :: Int
getExecutionCounter = Int
1
  , getLintStatus :: LintStatus
getLintStatus = LintStatus
LintOn
  , useSvg :: Bool
useSvg = Bool
True
  , useShowErrors :: Bool
useShowErrors = Bool
False
  , useShowTypes :: Bool
useShowTypes = Bool
False
  , usePager :: Bool
usePager = Bool
True
  , openComms :: Map UUID Widget
openComms = Map UUID Widget
forall a. Monoid a => a
mempty
  , kernelDebug :: Bool
kernelDebug = Bool
False
  , supportLibrariesAvailable :: Bool
supportLibrariesAvailable = Bool
True
  , htmlCodeWrapperClass :: Maybe String
htmlCodeWrapperClass = String -> Maybe String
forall a. a -> Maybe a
Just String
"CodeMirror cm-s-jupyter cm-s-ipython"
  , htmlCodeTokenPrefix :: String
htmlCodeTokenPrefix = String
"cm-"
  }

-- | Kernel options to be set via `:set` and `:option`.
data KernelOpt =
       KernelOpt
         { KernelOpt -> [String]
getOptionName :: [String] -- ^ Ways to set this option via `:option`
         , KernelOpt -> [String]
getSetName :: [String] -- ^ Ways to set this option via `:set`
         , KernelOpt -> KernelState -> KernelState
getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel
                                                              -- state.
         }

kernelOpts :: [KernelOpt]
kernelOpts :: [KernelOpt]
kernelOpts =
  [ [String] -> [String] -> (KernelState -> KernelState) -> KernelOpt
KernelOpt [String
"lint"] [] ((KernelState -> KernelState) -> KernelOpt)
-> (KernelState -> KernelState) -> KernelOpt
forall a b. (a -> b) -> a -> b
$ \KernelState
state -> KernelState
state { getLintStatus = LintOn }
  , [String] -> [String] -> (KernelState -> KernelState) -> KernelOpt
KernelOpt [String
"no-lint"] [] ((KernelState -> KernelState) -> KernelOpt)
-> (KernelState -> KernelState) -> KernelOpt
forall a b. (a -> b) -> a -> b
$ \KernelState
state -> KernelState
state { getLintStatus = LintOff }
  , [String] -> [String] -> (KernelState -> KernelState) -> KernelOpt
KernelOpt [String
"svg"] [] ((KernelState -> KernelState) -> KernelOpt)
-> (KernelState -> KernelState) -> KernelOpt
forall a b. (a -> b) -> a -> b
$ \KernelState
state -> KernelState
state { useSvg = True }
  , [String] -> [String] -> (KernelState -> KernelState) -> KernelOpt
KernelOpt [String
"no-svg"] [] ((KernelState -> KernelState) -> KernelOpt)
-> (KernelState -> KernelState) -> KernelOpt
forall a b. (a -> b) -> a -> b
$ \KernelState
state -> KernelState
state { useSvg = False }
  , [String] -> [String] -> (KernelState -> KernelState) -> KernelOpt
KernelOpt [String
"show-types"] [String
"+t"] ((KernelState -> KernelState) -> KernelOpt)
-> (KernelState -> KernelState) -> KernelOpt
forall a b. (a -> b) -> a -> b
$ \KernelState
state -> KernelState
state { useShowTypes = True }
  , [String] -> [String] -> (KernelState -> KernelState) -> KernelOpt
KernelOpt [String
"no-show-types"] [String
"-t"] ((KernelState -> KernelState) -> KernelOpt)
-> (KernelState -> KernelState) -> KernelOpt
forall a b. (a -> b) -> a -> b
$ \KernelState
state -> KernelState
state { useShowTypes = False }
  , [String] -> [String] -> (KernelState -> KernelState) -> KernelOpt
KernelOpt [String
"show-errors"] [] ((KernelState -> KernelState) -> KernelOpt)
-> (KernelState -> KernelState) -> KernelOpt
forall a b. (a -> b) -> a -> b
$ \KernelState
state -> KernelState
state { useShowErrors = True }
  , [String] -> [String] -> (KernelState -> KernelState) -> KernelOpt
KernelOpt [String
"no-show-errors"] [] ((KernelState -> KernelState) -> KernelOpt)
-> (KernelState -> KernelState) -> KernelOpt
forall a b. (a -> b) -> a -> b
$ \KernelState
state -> KernelState
state { useShowErrors = False }
  , [String] -> [String] -> (KernelState -> KernelState) -> KernelOpt
KernelOpt [String
"pager"] [] ((KernelState -> KernelState) -> KernelOpt)
-> (KernelState -> KernelState) -> KernelOpt
forall a b. (a -> b) -> a -> b
$ \KernelState
state -> KernelState
state { usePager = True }
  , [String] -> [String] -> (KernelState -> KernelState) -> KernelOpt
KernelOpt [String
"no-pager"] [] ((KernelState -> KernelState) -> KernelOpt)
-> (KernelState -> KernelState) -> KernelOpt
forall a b. (a -> b) -> a -> b
$ \KernelState
state -> KernelState
state { usePager = False }
  ]

-- | Current HLint status.
data LintStatus = LintOn
                | LintOff
  deriving (LintStatus -> LintStatus -> Bool
(LintStatus -> LintStatus -> Bool)
-> (LintStatus -> LintStatus -> Bool) -> Eq LintStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LintStatus -> LintStatus -> Bool
== :: LintStatus -> LintStatus -> Bool
$c/= :: LintStatus -> LintStatus -> Bool
/= :: LintStatus -> LintStatus -> Bool
Eq, Int -> LintStatus -> ShowS
[LintStatus] -> ShowS
LintStatus -> String
(Int -> LintStatus -> ShowS)
-> (LintStatus -> String)
-> ([LintStatus] -> ShowS)
-> Show LintStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LintStatus -> ShowS
showsPrec :: Int -> LintStatus -> ShowS
$cshow :: LintStatus -> String
show :: LintStatus -> String
$cshowList :: [LintStatus] -> ShowS
showList :: [LintStatus] -> ShowS
Show)

-- | Send JSON objects with specific formats
data WidgetMsg = Open Widget Value
               |
               -- ^ Cause the interpreter to open a new comm, and register the associated widget in
               -- the kernelState. Also sends an initial state Value with comm_open.
                Update Widget Value
               |
               -- ^ Cause the interpreter to send a comm_msg containing a state update for the
               -- widget. Can be used to send fragments of state for update. Also updates the value
               -- of widget stored in the kernelState
                View Widget
               |
               -- ^ Cause the interpreter to send a comm_msg containing a display command for the
               -- frontend.
                Close Widget Value
               |
               -- ^ Cause the interpreter to close the comm associated with the widget. Also sends
               -- data with comm_close.
                Custom Widget Value
               |
               -- ^ A [method .= custom, content = value] message
                JSONValue Widget Value
               |
               -- ^ A json object that is sent to the widget without modifications.
                DispMsg Widget Display
               |
               -- ^ A 'display_data' message, sent as a [method .= custom] comm_msg
                ClrOutput Bool
  -- ^ A 'clear_output' message, sent as a clear_output message
  deriving (Int -> WidgetMsg -> ShowS
[WidgetMsg] -> ShowS
WidgetMsg -> String
(Int -> WidgetMsg -> ShowS)
-> (WidgetMsg -> String)
-> ([WidgetMsg] -> ShowS)
-> Show WidgetMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WidgetMsg -> ShowS
showsPrec :: Int -> WidgetMsg -> ShowS
$cshow :: WidgetMsg -> String
show :: WidgetMsg -> String
$cshowList :: [WidgetMsg] -> ShowS
showList :: [WidgetMsg] -> ShowS
Show, Typeable)

data WidgetMethod = UpdateState Value [BufferPath]
                  | CustomContent Value
                  | DisplayWidget

instance ToJSON WidgetMethod where
  toJSON :: WidgetMethod -> Value
toJSON WidgetMethod
DisplayWidget = [Pair] -> Value
object [Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"display" :: Text)]
  toJSON (UpdateState Value
v [BufferPath]
bp) = [Pair] -> Value
object [Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"update" :: Text), Key
"state" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
v, Key
"buffer_paths" Key -> [BufferPath] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [BufferPath]
bp]
  toJSON (CustomContent Value
v) = [Pair] -> Value
object [Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"custom" :: Text), Key
"content" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
v]

-- | Output of evaluation.
--
-- A result can either be intermediate or final.
-- Final result has Mimebundles ('DisplayData') and Comm operations
-- ('WidgetMsg') on top of Display outputs.
data EvaluationResult
  -- | An intermediate result which communicates what has been printed thus far.
  = IntermediateResult
        !Display
  | FinalResult
        !Display
        ![DisplayData]
        ![WidgetMsg]
  deriving Int -> EvaluationResult -> ShowS
[EvaluationResult] -> ShowS
EvaluationResult -> String
(Int -> EvaluationResult -> ShowS)
-> (EvaluationResult -> String)
-> ([EvaluationResult] -> ShowS)
-> Show EvaluationResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EvaluationResult -> ShowS
showsPrec :: Int -> EvaluationResult -> ShowS
$cshow :: EvaluationResult -> String
show :: EvaluationResult -> String
$cshowList :: [EvaluationResult] -> ShowS
showList :: [EvaluationResult] -> ShowS
Show


evaluationOutputs :: EvaluationResult -> Display
evaluationOutputs :: EvaluationResult -> Display
evaluationOutputs EvaluationResult
er =
  case EvaluationResult
er of
    IntermediateResult Display
outputs -> Display
outputs
    FinalResult Display
outputs [DisplayData]
_ [WidgetMsg]
_ -> Display
outputs

-- | Duplicate a message header, giving it a new UUID and message type.
dupHeader :: MessageHeader -> MessageType -> IO MessageHeader
dupHeader :: MessageHeader -> MessageType -> IO MessageHeader
dupHeader MessageHeader
hdr MessageType
messageType = do
  UUID
uuid <- IO UUID -> IO UUID
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
random
  MessageHeader -> IO MessageHeader
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MessageHeader
hdr { mhMessageId = uuid, mhMsgType = messageType }

-- | Modifies a header and appends the version of the Widget Messaging Protocol as metadata
setVersion :: MessageHeader  -- ^ The header to modify
           -> String         -- ^ The version to set
           -> MessageHeader  -- ^ The modified header

-- We use the 'fromList' function from "Data.HashMap.Strict" (or
-- "Data.Aeson.KeyMap") instead of the 'object' function from "Data.Aeson"
-- because 'object' returns a 'Value', but metadata needs an 'Object'.
#if MIN_VERSION_aeson(2,0,0)
setVersion :: MessageHeader -> String -> MessageHeader
setVersion MessageHeader
hdr String
v = MessageHeader
hdr { mhMetadata = Metadata (KeyMap.fromList [("version", String $ pack v)]) }
#else
setVersion hdr v = hdr { mhMetadata = Metadata (HashMap.fromList [("version", String $ pack v)]) }
#endif

-- | Whether or not an error occurred.
data ErrorOccurred = Success
                   | Failure
  deriving (Int -> ErrorOccurred -> ShowS
[ErrorOccurred] -> ShowS
ErrorOccurred -> String
(Int -> ErrorOccurred -> ShowS)
-> (ErrorOccurred -> String)
-> ([ErrorOccurred] -> ShowS)
-> Show ErrorOccurred
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorOccurred -> ShowS
showsPrec :: Int -> ErrorOccurred -> ShowS
$cshow :: ErrorOccurred -> String
show :: ErrorOccurred -> String
$cshowList :: [ErrorOccurred] -> ShowS
showList :: [ErrorOccurred] -> ShowS
Show, ErrorOccurred -> ErrorOccurred -> Bool
(ErrorOccurred -> ErrorOccurred -> Bool)
-> (ErrorOccurred -> ErrorOccurred -> Bool) -> Eq ErrorOccurred
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorOccurred -> ErrorOccurred -> Bool
== :: ErrorOccurred -> ErrorOccurred -> Bool
$c/= :: ErrorOccurred -> ErrorOccurred -> Bool
/= :: ErrorOccurred -> ErrorOccurred -> Bool
Eq)