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(..)) ...@@ -7,6 +7,7 @@ import System.IO (hSetEcho,hSetBuffering,BufferMode(..),openFile,IOMode(..))
import Data.IORef import Data.IORef
import qualified System.Console.Terminal.Size as TSize import qualified System.Console.Terminal.Size as TSize
import Control.DeepSeq (($!!)) import Control.DeepSeq (($!!))
import Control.Exception (bracket_)
tty = (openFile "/dev/tty" ReadWriteMode <*= \h -> hSetBuffering h NoBuffering)^.thunk tty = (openFile "/dev/tty" ReadWriteMode <*= \h -> hSetBuffering h NoBuffering)^.thunk
...@@ -61,7 +62,7 @@ rlFuture = lens _rlFuture (\x y -> x { _rlFuture = y }) ...@@ -61,7 +62,7 @@ rlFuture = lens _rlFuture (\x y -> x { _rlFuture = y })
rl_stateref = (readHString tty >>= \s -> newIORef (s,[],\_ -> return []))^.thunk rl_stateref = (readHString tty >>= \s -> newIORef (s,[],\_ -> return []))^.thunk
readline :: String -> IO (Maybe String) 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 writeHString tty prompt
(inp,hist,complete) <- readIORef rl_stateref (inp,hist,complete) <- readIORef rl_stateref
(st',l) <- ((axiom complete^..parserT) inp^..stateT) (RLState zero zero hist zero) (st',l) <- ((axiom complete^..parserT) inp^..stateT) (RLState zero zero hist zero)
......
...@@ -4,7 +4,7 @@ module Main where ...@@ -4,7 +4,7 @@ module Main where
import Algebra.Monad.Concatenative import Algebra.Monad.Concatenative
import Codec.Picture hiding (Uniform) import Codec.Picture hiding (Uniform)
import Console.Readline (readline,addHistory,setCompletionEntryFunction) import Console.Readline (readline,addHistory,setCompletionEntryFunction)
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay, forkIO, killThread)
import Control.Exception (SomeException(..),Exception) import Control.Exception (SomeException(..),Exception)
import Data.IORef import Data.IORef
import Data.Matricial import Data.Matricial
...@@ -17,6 +17,7 @@ import Language.Parser ...@@ -17,6 +17,7 @@ import Language.Parser
import System.Environment (getArgs) import System.Environment (getArgs)
import System.IO (hIsTerminalDevice) import System.IO (hIsTerminalDevice)
import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Concurrent.Chan
import qualified Data.StateVar as SV import qualified Data.StateVar as SV
import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable as V
...@@ -58,10 +59,13 @@ data LogosData = F GL.GLfloat ...@@ -58,10 +59,13 @@ data LogosData = F GL.GLfloat
| TI GL.TextureObject | TI GL.TextureObject
deriving Show deriving Show
data LogosState = LogosState { data LogosState = LogosState {
_running :: Bool _running :: Bool,
_wordChannel :: Chan String
} }
running :: Lens' LogosState Bool running :: Lens' LogosState Bool
running = lens _running (\x y -> x { _running = y }) running = lens _running (\x y -> x { _running = y })
wordChannel :: Lens' LogosState (Chan String)
wordChannel = lens _wordChannel (\x y -> x { _wordChannel = y })
dict = fromAList $ dict = fromAList $
(".",StackProg []): (".",StackProg []):
...@@ -200,6 +204,7 @@ runLogos OpenWindow = do ...@@ -200,6 +204,7 @@ runLogos OpenWindow = do
case st of case st of
StackInt h:StackInt w:st' -> do StackInt h:StackInt w:st' -> do
runStackState $ put st' runStackState $ put st'
wc <- runExtraState $ getl wordChannel
void $ liftIO $ do void $ liftIO $ do
GLFW.openWindowHint GLFW.FSAASamples 4 GLFW.openWindowHint GLFW.FSAASamples 4
GLFW.openWindowHint GLFW.OpenGLVersionMajor 3 GLFW.openWindowHint GLFW.OpenGLVersionMajor 3
...@@ -207,7 +212,15 @@ runLogos OpenWindow = do ...@@ -207,7 +212,15 @@ runLogos OpenWindow = do
GLFW.openWindowHint GLFW.OpenGLProfile GLFW.OpenGLCoreProfile 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 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 _ -> unit
runLogos Uniform = do runLogos Uniform = do
st <- runStackState get st <- runStackState get
...@@ -354,27 +367,33 @@ main = between (void GLFW.initialize) GLFW.terminate $ do ...@@ -354,27 +367,33 @@ main = between (void GLFW.initialize) GLFW.terminate $ do
args <- getArgs args <- getArgs
prelude <- fold <$> for args readString prelude <- fold <$> for args readString
symList <- newIORef (keys (c'map dict)) symList <- newIORef (keys (c'map dict))
let getAll = unsafeInterleaveIO $ do wordChan <- newChan
ln <- readline "Logos> "
lns <- getAll tid <- forkIO $ do
case ln of let getAll = unsafeInterleaveIO $ do
Just x -> do addHistory x; return $ x + " .\n" + lns ln <- readline "Logos> "
Nothing -> putStr "\n" >> return "" lns <- getAll
setCompletionEntryFunction $ Just $ \line -> do case ln of
sl <- readIORef symList Just x -> do addHistory x; return $ x + " .\n" + lns
case reverse (words (line+"?")) of Nothing -> putStr "\n" >> return ""
"?":_ -> return sl setCompletionEntryFunction $ Just $ \line -> do
wp:_ -> let wps = length wp-1; wp' = init wp in return [w | w <- sl, take wps w==wp'] sl <- readIORef symList
_ -> return [] case reverse (words (line+"?")) of
text <- if isTerm then getAll else readHString stdin "?":_ -> return sl
wp:_ -> let wps = length wp-1; wp' = init wp in return [w | w <- sl, take wps w==wp']
let go (w:ws) = do _ -> 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 execSymbol runLogos (\_ -> unit) w
runDictState get >>= \d -> liftIO (writeIORef symList (keys d)) runDictState get >>= \d -> liftIO (writeIORef symList (keys d))
r <- runExtraState $ getl running r <- runExtraState $ getl running
if r then go ws else unit if r then go else unit
go [] = unit (go^..stateT.concatT) (defaultState dict (LogosState True wordChan))
(go (stringWords (prelude + " " + text))^..stateT.concatT) (defaultState dict (LogosState True)) killThread tid
instance Storable (Vec Zero a) where instance Storable (Vec Zero a) where
sizeOf _ = zero sizeOf _ = zero
......
Markdown is supported
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