Handler.hs

{-|
Module      : Calculator.Handler
Description : The request handling for the calculator kernel.
Copyright   : (c) Andrew Gibiansky, 2016
License     : MIT
Maintainer  : andrew.gibiansky@gmail.com
Stability   : stable
Portability : POSIX

This module implements the main request handler ('ClientRequestHandler') for the demo Calculator
kernel that comes with the @jupyter@ package.

The Calculator kernel implements a very simple language, represented by the following AST:

@
data Expr = Lit Int
          | Add Expr Expr
          | Multiply Expr Expr
          | Subtract Expr Expr
          | Divide Expr Expr
          | Negate Expr
          | Var Char

data Statement = Compute [(Char, Int)] Expr
               | Print Expr
@

Expressions in our calculator are represented by an @Expr@, and the things calculator the
calculator can do with the expressions are the constructors of @Statement@:
  * @Compute@: Given a mapping from variables to values, compute and print the value of the expression.
  * @Print@: Print a representation of the expression (emits both plain text and LaTeX).

The kernel features implemented by this kernel include code execution, autocompletion of 
constructor names, and inspection of constructor names. To simplify the code, parsing is omitted,
and instead the entire language syntax is simply Haskell expressions, so that we can use the
derived 'Read' parsers.

-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Calculator.Handler (requestHandler) where

-- Imports from 'base'
import           Control.Concurrent (MVar, modifyMVar)
import           Data.List (nub)
import           Data.Monoid ((<>))
import           Text.Read (readMaybe)

-- Imports from 'text'
import           Data.Text (Text)
import qualified Data.Text as T

-- Imports from 'jupyter'
import           Jupyter.Kernel (defaultClientRequestHandler, KernelProfile, KernelCallbacks(..))
import           Jupyter.Messages (ClientRequest(..), KernelReply(..), KernelInfo(..),
                                   LanguageInfo(..), HelpLink(..), CodeBlock(..), CodeOffset(..),
                                   ExecutionCount, KernelOutput(..), ErrorInfo(..), displayPlain,
                                   displayLatex, CompletionMatch(..), CursorRange(..),
                                   pattern CompleteOk, pattern ExecuteOk, pattern InspectOk,
                                   pattern ExecuteError)

-- | An expression in our simple calculator language. Values are all integers, but variables are
-- represented by a single character name @Var@ constructor.
data Expr = Lit Int
          | Add Expr Expr
          | Multiply Expr Expr
          | Subtract Expr Expr
          | Divide Expr Expr
          | Negate Expr
          | Var Char
  deriving (Eq, Ord, Show, Read)

-- | Statements representing the things we can do with our expressions.
data Statement = Compute [(Char, Int)] Expr -- ^ Compute the value of an expression, substituting
                                            -- variables as necessary. If variables are left over
                                            -- after substitution, an error is raised.
               | Print Expr  -- ^ Print a mathematical representation of the expression.
  deriving (Eq, Ord, Show, Read)

-- | Parse a 'Statement' in our language by using its Read instance.
parse :: Text -> Maybe Statement
parse = readMaybe . T.unpack

-- | Evaluate an expression, substituting in variables as necessary. If any variables are
-- unevaluated or division by zero occurs, yields Nothing.
eval :: [(Char, Int)] -> Expr -> Maybe Int
eval vars expr =
  case expr of
    Lit i -> return i
    Add a b -> (+) <$> eval vars a <*> eval vars b
    Multiply a b -> (*) <$> eval vars a <*> eval vars b
    Subtract a b -> (-) <$> eval vars a <*> eval vars b
    Divide a b -> do
      denom <- eval vars b
      if denom == 0
        then Nothing
        else div <$> eval vars a <*> pure denom
    Negate a -> negate <$> eval vars a
    Var c -> lookup c vars

-- | Print an expression as an ASCII string.
--
-- Do not bother with clean parentheses, this is just a demo!
printText :: Expr -> String
printText expr =
  case expr of
    Lit i        -> show i
    Var c        -> [c]
    Negate e     -> '-' : printText e
    Add a b      -> concat ["(", printText a, " + ", printText b, ")"]
    Multiply a b -> concat ["(", printText a, " * ", printText b, ")"]
    Subtract a b -> concat ["(", printText a, " - ", printText b, ")"]
    Divide a b   -> concat ["(", printText a, " / ", printText b, ")"]

-- | Print an expression as a LaTeX string.
printLatex :: Expr -> String
printLatex expr =
  case expr of
    Lit i        -> show i
    Var c        -> [c]
    Negate e     -> '-' : printLatex e
    Add a b      -> concat ["(", printLatex a, " + ", printLatex b, ")"]
    Multiply a b -> concat ["(", printLatex a, " \\cdot ", printLatex b, ")"]
    Subtract a b -> concat ["(", printLatex a, " - ", printLatex b, ")"]
    Divide a b   -> concat ["\\frac{", printLatex a, "}{", printLatex b, "}"]

-- | List of symbols that should be part of autocompletions.
autocompleteSymbols :: [Text]
autocompleteSymbols = map fst tokenDocumentation

-- | Documentation for symbols in our language, stored as an association list.
tokenDocumentation :: [(Text, Text)]
tokenDocumentation =
  [ ("Lit", "Lit: Create an integer literal.")
  , ("Var", "Var: Create a variable with a single character name.")
  , ("Negate", "Negate: Negate an expression.")
  , ("Add", "Add: Add two expressions.")
  , ("Multiply", "Multiply: Multiply two expressions.")
  , ("Subtract", "Subtract: Subtract one expression from another.")
  , ("Divide", "Divide: Divide an expression by another.")
  , ("Compute", "Compute: Given an expression and variable bindings, compute the expression value.")
  , ("Print", "Print: Print an expression as text or LaTeX.")
  ]

-- | The main request handler for the Calculator kernel.
--
-- The request handler is responsible for generating a KernelReply when given a ClientRequest, optionally
-- publishing results using the callbacks provided to it in the 'KernelCallbacks' record.
requestHandler :: KernelProfile -> MVar ExecutionCount -> KernelCallbacks -> ClientRequest -> IO KernelReply
requestHandler profile execCountVar callbacks req =
  case req of
    ExecuteRequest code _ ->
      -- For this simple kernel, ignore the execution options, as they do not apply
      -- to our simple kernel. Also, automatically increment the execution counter.
      modifyMVar execCountVar $ \execCount -> do
        -- Kernels are responsible for broadcasting any execution request code blocks they receive
        -- to all connected frontends via kernel outputs.
        sendKernelOutput callbacks $ ExecuteInputOutput execCount code

        reply <- handleExecuteRequest execCount code callbacks
        return (execCount + 1, reply)
    InspectRequest code offset _ ->
      -- Ignore the detail level, because for this simple kernel we don't have
      -- documentation of identifiers at multiple detail levels.
      handleInspectRequest code offset
    CompleteRequest code offset -> handleCompleteRequest code offset
    other ->
      -- Any unhandled messages can be handled in the default manner.
      defaultClientRequestHandler profile kernelInfo callbacks other
  where
    -- This KernelInfo is returned by the default client request handler when it receives a
    -- KernelInfoRequest message, which is usually the first message that the client sends to the
    -- kernel.
    kernelInfo = KernelInfo
      { kernelProtocolVersion = "5.0"
      , kernelBanner = "Welcome to the Haskell Calculator Test Kernel!"
      , kernelImplementation = "Calculator-Kernel"
      , kernelImplementationVersion = "1.0"
      , kernelHelpLinks = [ HelpLink "jupyter package doc"
                              "http://github.com/gibiansky/jupyter-haskell"
                          ]
      , kernelLanguageInfo = LanguageInfo
        { languageName = "calculator"
        , languageVersion = "1.0"
        , languageMimetype = "text/plain"
        , languageFileExtension = ".txt"
        , languagePygmentsLexer = Nothing
        , languageCodeMirrorMode = Nothing
        , languageNbconvertExporter = Nothing
        }
      }

-- | Given a block of code and a cursor offset in the code, tokenize the code and extract the token
-- immediately preceeding the cursor. A token is defined a contiguous set of alphanumeric
-- characters.
--
-- >>> findPreceedingToken "xyz (Hello)" 9 == "Hell"
findPreceedingToken :: Text -> Int -> Text
findPreceedingToken code offset =
  let beforeCursor = T.take offset code
      allowedSymbolChars = nub $ T.unpack $ T.concat autocompleteSymbols
      token = T.takeWhileEnd (`elem` allowedSymbolChars) beforeCursor
  in token

-- | Generate a 'KernelReply' for an 'ExecuteRequest', sending any necessary outputs in the process.
handleExecuteRequest :: ExecutionCount -> CodeBlock -> KernelCallbacks -> IO KernelReply
handleExecuteRequest execCount (CodeBlock code) KernelCallbacks { .. } =
  case parse code of
    Nothing -> do
      -- Parse error!
      let errMsg = "Could not parse: '" <> code <> "'"
      sendKernelOutput $ DisplayDataOutput $ displayPlain errMsg
      reply $ ExecuteError
                ErrorInfo { errorName = "Parse Error", errorValue = errMsg, errorTraceback = [] }
    Just (Compute bindings expr) ->
      case eval bindings expr of
        Nothing -> do
          let errMsg = "Missing variable bindings in: '" <> code <> "'"
          sendKernelOutput $ DisplayDataOutput $ displayPlain errMsg
          reply $ ExecuteError
                    ErrorInfo { errorName = "Eval Error", errorValue = errMsg, errorTraceback = [] }
        Just val -> do
          sendKernelOutput $ DisplayDataOutput $ displayPlain $ T.pack $ show val
          reply ExecuteOk

    Just (Print expr) -> do
      let text = T.pack $ printText expr
          latex = T.pack $ printLatex expr
      sendKernelOutput $ DisplayDataOutput $ displayPlain text <> displayLatex latex
      reply ExecuteOk
  where
    reply = return . ExecuteReply execCount

-- | Generate a 'KernelReply' for an 'InspectRequest'.
handleInspectRequest :: CodeBlock -> CodeOffset -> IO KernelReply
handleInspectRequest (CodeBlock code) (CodeOffset offset) =
  let token = findPreceedingToken code offset
  in return . InspectReply . InspectOk $ displayPlain <$> lookup token tokenDocumentation

-- | Generate autocompletions for the symbols used in our language.
--
-- The algorithm for autocompleting is very simple: find the preceeding token by looking at which
-- characters are allowed in symbols, then search through all available symbols to find which ones
-- start with the found token.
handleCompleteRequest :: CodeBlock -> CodeOffset -> IO KernelReply
handleCompleteRequest (CodeBlock code) (CodeOffset offset) =
  let token = findPreceedingToken code offset
      start = offset - T.length token
      completions = filter (T.isPrefixOf token) autocompleteSymbols
  in return $ CompleteReply $
    CompleteOk (map CompletionMatch completions) (CursorRange start offset) mempty