Commit 232c7c9c authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Implement basic event handling in Logos

parent 3b4f33e9
......@@ -7,6 +7,7 @@ import System.IO (hSetEcho,hSetBuffering,BufferMode(..),openFile,IOMode(..))
import Data.IORef
import qualified System.Console.Terminal.Size as TSize
import Control.DeepSeq (($!!))
import Control.Exception (bracket_)
tty = (openFile "/dev/tty" ReadWriteMode <*= \h -> hSetBuffering h NoBuffering)^.thunk
......@@ -61,7 +62,7 @@ rlFuture = lens _rlFuture (\x y -> x { _rlFuture = y })
rl_stateref = (readHString tty >>= \s -> newIORef (s,[],\_ -> return []))^.thunk
readline :: String -> IO (Maybe String)
readline prompt = between (hSetEcho tty False) (hSetEcho tty True) $ do
readline prompt = bracket_ (hSetEcho tty False) (hSetEcho tty True) $ do
writeHString tty prompt
(inp,hist,complete) <- readIORef rl_stateref
(st',l) <- ((axiom complete^..parserT) inp^..stateT) (RLState zero zero hist zero)
......
......@@ -4,7 +4,7 @@ module Main where
import Algebra.Monad.Concatenative
import Codec.Picture hiding (Uniform)
import Console.Readline (readline,addHistory,setCompletionEntryFunction)
import Control.Concurrent (threadDelay)
import Control.Concurrent (threadDelay, forkIO, killThread)
import Control.Exception (SomeException(..),Exception)
import Data.IORef
import Data.Matricial
......@@ -17,6 +17,7 @@ import Language.Parser
import System.Environment (getArgs)
import System.IO (hIsTerminalDevice)
import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Concurrent.Chan
import qualified Data.StateVar as SV
import qualified Data.Vector.Storable as V
......@@ -58,10 +59,13 @@ data LogosData = F GL.GLfloat
| TI GL.TextureObject
deriving Show
data LogosState = LogosState {
_running :: Bool
_running :: Bool,
_wordChannel :: Chan String
}
running :: Lens' LogosState Bool
running = lens _running (\x y -> x { _running = y })
wordChannel :: Lens' LogosState (Chan String)
wordChannel = lens _wordChannel (\x y -> x { _wordChannel = y })
dict = fromAList $
(".",StackProg []):
......@@ -200,6 +204,7 @@ runLogos OpenWindow = do
case st of
StackInt h:StackInt w:st' -> do
runStackState $ put st'
wc <- runExtraState $ getl wordChannel
void $ liftIO $ do
GLFW.openWindowHint GLFW.FSAASamples 4
GLFW.openWindowHint GLFW.OpenGLVersionMajor 3
......@@ -207,7 +212,15 @@ runLogos OpenWindow = do
GLFW.openWindowHint GLFW.OpenGLProfile GLFW.OpenGLCoreProfile
success <- GLFW.openWindow (GL.Size (fromIntegral w) (fromIntegral h)) [GLFW.DisplayRGBBits 8 8 8, GLFW.DisplayAlphaBits 8, GLFW.DisplayDepthBits 8] GLFW.Window
if not success then throw $ SomeException GLFWWindowOpenException else (initGL >> initShaders)
if not success then throw $ SomeException GLFWWindowOpenException else do
initGL >> initShaders
forkIO $ forever $ GLFW.pollEvents >> threadDelay 50000
GLFW.keyCallback $= \k ev -> do
putStrLn $ "Key : "+show (k,ev)
writeChan wc $ "'"+case k of GLFW.CharKey c -> [c] ; GLFW.SpecialKey s -> show s
writeChan wc $ "'"+case ev of GLFW.Press -> "press" ; GLFW.Release -> "release"
writeChan wc $ "onkey"
_ -> unit
runLogos Uniform = do
st <- runStackState get
......@@ -354,27 +367,33 @@ main = between (void GLFW.initialize) GLFW.terminate $ do
args <- getArgs
prelude <- fold <$> for args readString
symList <- newIORef (keys (c'map dict))
let getAll = unsafeInterleaveIO $ do
ln <- readline "Logos> "
lns <- getAll
case ln of
Just x -> do addHistory x; return $ x + " .\n" + lns
Nothing -> putStr "\n" >> return ""
setCompletionEntryFunction $ Just $ \line -> do
sl <- readIORef symList
case reverse (words (line+"?")) of
"?":_ -> return sl
wp:_ -> let wps = length wp-1; wp' = init wp in return [w | w <- sl, take wps w==wp']
_ -> return []
text <- if isTerm then getAll else readHString stdin
let go (w:ws) = do
wordChan <- newChan
tid <- forkIO $ do
let getAll = unsafeInterleaveIO $ do
ln <- readline "Logos> "
lns <- getAll
case ln of
Just x -> do addHistory x; return $ x + " .\n" + lns
Nothing -> putStr "\n" >> return ""
setCompletionEntryFunction $ Just $ \line -> do
sl <- readIORef symList
case reverse (words (line+"?")) of
"?":_ -> return sl
wp:_ -> let wps = length wp-1; wp' = init wp in return [w | w <- sl, take wps w==wp']
_ -> return []
text <- if isTerm then getAll else unsafeInterleaveIO $ readHString stdin
for_ (stringWords (prelude + " " + text)) (writeChan wordChan)
let go = do
w <- liftIO $ readChan wordChan
execSymbol runLogos (\_ -> unit) w
runDictState get >>= \d -> liftIO (writeIORef symList (keys d))
r <- runExtraState $ getl running
if r then go ws else unit
go [] = unit
(go (stringWords (prelude + " " + text))^..stateT.concatT) (defaultState dict (LogosState True))
if r then go else unit
(go^..stateT.concatT) (defaultState dict (LogosState True wordChan))
killThread tid
instance Storable (Vec Zero a) where
sizeOf _ = zero
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment