{-# 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"