Merge branch 'master' of github.com:gibiansky/IHaskell

ipython-kernel/examples/Calc.hs

+{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, MultiWayIf #-}
+module Main where
+
+import Control.Applicative
+import Control.Arrow
+
+import Control.Concurrent (MVar, newMVar, takeMVar, putMVar, threadDelay)
+import Control.Monad (guard)
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.State.Strict (StateT, get, modify, runStateT)
+
+import Data.Char (isDigit)
+import Data.List (isPrefixOf)
+import Data.Monoid ((<>))
+import qualified Data.Text as T
+
+import IHaskell.IPython.Kernel
+import IHaskell.IPython.EasyKernel (installProfile, easyKernel, KernelConfig(..))
+
+import System.Environment (getArgs)
+import System.FilePath ((</>))
+
+import Text.Parsec (Parsec, ParseError, alphaNum, char, letter, oneOf, optionMaybe, runParser, (<?>))
+import qualified Text.Parsec.Token as P
+
+import qualified Paths_ipython_kernel as Paths
+
+---------------------------------------------------------
+--  Hutton's Razor, plus time delays, plus a global state
+---------------------------------------------------------
+
+-- | This language is Hutton's Razor with two added operations that
+-- are needed to demonstrate the kernel features: a global state,
+-- accessed and modified using Count, and a sleep operation.
+data Razor = I Integer
+           | Plus Razor Razor
+           | SleepThen Double Razor
+           | Count
+  deriving (Read, Show, Eq)
+
+
+---------
+-- Parser
+---------
+
+razorDef :: Monad m => P.GenLanguageDef String a m
+razorDef = P.LanguageDef
+  { P.commentStart    = "(*"
+  , P.commentEnd      = "*)"
+  , P.commentLine     = "//"
+  , P.nestedComments  = True
+  , P.identStart      = letter <|> char '_'
+  , P.identLetter     = alphaNum <|> char '_'
+  , P.opStart         = oneOf "+"
+  , P.opLetter        = oneOf "+"
+  , P.reservedNames   = ["sleep", "then", "end", "count"]
+  , P.reservedOpNames = []
+  , P.caseSensitive   = True
+  }
+
+lexer :: Monad m => P.GenTokenParser String a m
+lexer = P.makeTokenParser razorDef
+
+parens :: Parsec String a b -> Parsec String a b
+parens = P.parens lexer
+
+reserved :: String -> Parsec String a ()
+reserved = P.reserved lexer
+
+integer :: Parsec String a Integer
+integer = P.integer lexer
+
+float :: Parsec String a Double
+float = P.float lexer
+
+operator :: Parsec String a String
+operator = P.operator lexer
+
+keyword :: String -> Parsec String a ()
+keyword kwd = reserved kwd <?> "the keyword \"" ++ kwd ++ "\""
+
+literal :: Parsec String a Razor
+literal = I <$> integer
+
+sleepThen :: Parsec String a Razor
+sleepThen = do keyword "sleep"
+               delay <- float <?> "seconds"
+               keyword "then"
+               body <- expr
+               keyword "end" <?> ""
+               return $ SleepThen delay body
+
+count :: Parsec String a Razor
+count = keyword "count" >> return Count
+
+expr :: Parsec String a Razor
+expr = do one <- parens expr <|> literal <|> sleepThen <|> count
+          rest <- optionMaybe (do op <- operator
+                                  guard (op == "+")
+                                  expr)
+          case rest of
+            Nothing -> return one
+            Just other -> return $ Plus one other
+
+parse :: String -> Either ParseError Razor
+parse = runParser expr () "(input)"
+
+
+----------------------
+-- Language operations
+----------------------
+
+-- | Completion
+langCompletion :: T.Text -> T.Text -> Int -> Maybe ([T.Text], T.Text, T.Text)
+langCompletion _code line col =
+  let (before, _) = T.splitAt col line
+  in fmap (\word -> (map T.pack . matchesFor $ T.unpack word, word, word))
+          (lastMaybe (T.words before))
+  where
+    lastMaybe :: [a] -> Maybe a
+    lastMaybe [] = Nothing
+    lastMaybe [x] = Just x
+    lastMaybe (_:xs) = lastMaybe xs
+    matchesFor :: String -> [String]
+    matchesFor input = filter (isPrefixOf input) available
+    available = ["sleep", "then", "end", "count"] ++ map show [(-1000::Int)..1000]
+
+-- | Documentation lookup
+langInfo :: T.Text -> Maybe (T.Text, T.Text, T.Text)
+langInfo obj =
+  if | any (T.isPrefixOf obj) ["sleep", "then", "end"] ->
+       Just (obj, sleepDocs, sleepType)
+     | T.isPrefixOf obj "count" ->
+       Just (obj, countDocs, countType)
+     | obj == "+" -> Just (obj, plusDocs, plusType)
+     | T.all isDigit obj -> Just (obj, intDocs obj, intType)
+     | [x, y] <- T.splitOn "." obj,
+       T.all isDigit x,
+       T.all isDigit y -> Just (obj, floatDocs obj, floatType)
+     | otherwise -> Nothing
+  where
+    sleepDocs    = "sleep DURATION then VALUE end: sleep DURATION seconds, then eval VALUE"
+    sleepType    = "sleep FLOAT then INT end"
+    plusDocs     = "Perform addition"
+    plusType     = "INT + INT"
+    intDocs i    = "The integer " <> i
+    intType      = "INT"
+    floatDocs f  = "The floating point value " <> f
+    floatType    = "FLOAT"
+    countDocs    = "Increment and return the current counter"
+    countType    = "INT"
+
+-- | Messages sent to the frontend during evaluation will be lists of trace elements
+data IntermediateEvalRes = Got Razor Integer
+                         | Waiting Double
+  deriving Show
+
+-- | Cons for lists of trace elements - in this case, "sleeping"
+-- messages should replace old ones to create a countdown effect.
+consRes :: IntermediateEvalRes -> [IntermediateEvalRes] -> [IntermediateEvalRes]
+consRes r@(Waiting _) (Waiting _ : s) = r:s
+consRes r s = r:s
+
+-- | Execute an expression.
+execRazor :: MVar Integer -- ^ The global counter state
+          -> Razor -- ^ The term to execute
+          -> IO () -- ^ Callback to clear output so far
+          -> ([IntermediateEvalRes] -> IO ()) -- ^ Callback for intermediate results
+          -> StateT ([IntermediateEvalRes], T.Text) IO Integer
+execRazor _ x@(I i) _ _ =
+  modify (second (<> (T.pack (show x)))) >> return i
+execRazor val tm@(Plus x y) clear send =
+   do modify (second (<> (T.pack (show tm))))
+      x' <- execRazor val x clear send
+      modify (first $ consRes (Got x x'))
+      sendState
+      y' <- execRazor val y clear send
+      modify (first $ consRes (Got y y'))
+      sendState
+      let res = x' + y'
+      modify (first $ consRes (Got tm res))
+      sendState
+      return res
+  where sendState = liftIO clear >> fst <$> get >>= liftIO . send
+execRazor val (SleepThen delay body) clear send
+  | delay <= 0.0 = execRazor val body clear send
+  | delay >  0.1 = do modify (first $ consRes (Waiting delay))
+                      sendState
+                      liftIO $ threadDelay 100000
+                      execRazor val (SleepThen (delay - 0.1) body) clear send
+  | otherwise = do modify (first $ consRes (Waiting 0))
+                   sendState
+                   liftIO $ threadDelay (floor (delay * 1000000))
+                   execRazor val body clear send
+  where sendState = liftIO clear >> fst <$> get >>= liftIO . send
+execRazor val Count clear send = do
+  i <- liftIO $ takeMVar val
+  modify (first $ consRes (Got Count i))
+  sendState
+  liftIO $ putMVar val (i+1)
+  return i
+
+  where sendState = liftIO clear >> fst <$> get >>= liftIO . send
+
+-- | Generate a language configuration for some initial state
+mkConfig :: MVar Integer -- ^ The internal state of the execution
+         -> KernelConfig IO [IntermediateEvalRes] (Either ParseError Integer)
+mkConfig var = KernelConfig
+  { languageName     = "expanded_huttons_razor"
+  , languageVersion  = [0,1,0]
+  , profileSource    = Just . (</> "calc_profile.tar") <$> Paths.getDataDir
+  , displayResult    = displayRes
+  , displayOutput    = displayOut
+  , completion       = langCompletion
+  , objectInfo       = langInfo
+  , run              = parseAndRun
+  , debug            = False
+  }
+  where
+    displayRes (Left err) =
+      [ DisplayData MimeHtml . T.pack $ "<em>" ++ show err ++ "</em>"
+      , DisplayData PlainText . T.pack $ show err
+      ]
+    displayRes (Right x) =
+      return . DisplayData MimeHtml . T.pack $
+        "Answer: <strong>" ++ show x ++ "</strong>"
+    displayOut out =
+      let outLines = reverse (map (T.pack . show) out)
+      in return (DisplayData PlainText (T.unlines outLines))
+    parseAndRun code clear send =
+      case parse (T.unpack code) of
+        Left err -> return (Left err, Err, "")
+        Right tm -> do
+          (res, (_, pager)) <- runStateT (execRazor var tm clear send) ([], "")
+          return (Right res, Ok, T.unpack pager)
+
+main :: IO ()
+main = do args <- getArgs
+          val <- newMVar 1
+          case args of
+            ["kernel", profileFile] ->
+              easyKernel profileFile (mkConfig val)
+            ["setup"] -> do
+              putStrLn "Installing profile..."
+              installProfile (mkConfig val)
+            _ -> do
+              putStrLn "Usage:"
+              putStrLn "simple-calc-example setup        -- set up the profile"
+              putStrLn "simple-calc-example kernel FILE  -- run a kernel with FILE for communication with the frontend"

ipython-kernel/ipython-kernel.cabal

@@ -14,6 +14,15 @@ build-type:          Simple
 
 cabal-version:       >=1.16
 
+data-dir:            example-data
+data-files:          calc_profile.tar
+
+
+flag examples
+  description: Build example programs
+  default:     False
+
+
 library
   exposed-modules: IHaskell.IPython.Kernel
                    IHaskell.IPython.Types
@@ -22,6 +31,7 @@ library
                    IHaskell.IPython.Message.Writer
                    IHaskell.IPython.Message.Parser
                    IHaskell.IPython.Message.UUID
+                   IHaskell.IPython.EasyKernel
   -- other-modules:       
   other-extensions:    OverloadedStrings
   hs-source-dirs:      src
@@ -31,7 +41,28 @@ library
                        bytestring      >=0.10,
                        cereal          >=0.3,
                        containers      >=0.5,
+                       directory       >=1.1,
+                       filepath        >=1.2,
+                       mtl             >=2.1,
+                       tar             >=0.4.0.1,
                        text            >=0.11,
+                       transformers    >=0.3,
                        unix            >=2.6,
                        uuid            >=1.3,
                        zeromq4-haskell >=0.1
+
+
+-- Example program
+executable simple-calc-example
+  hs-source-dirs: examples
+  main-is:        Calc.hs
+  build-depends:  ipython-kernel,
+                  base           >=4.6 && <4.8,
+                  filepath       >=1.2,
+                  mtl            >=2.1,
+                  parsec         >=3.1,
+                  text           >=0.11,
+                  transformers   >=0.3
+                  
+  if !flag(examples)
+    buildable: False