yi-0.5.2: Yi/UI/Cocoa/Application.hs
{-# LANGUAGE TemplateHaskell, EmptyDataDecls, MultiParamTypeClasses, ForeignFunctionInterface #-}
--
-- Copyright (c) 2008 Gustav Munkby
--
-- | This module defines Cocoa event handling
-- For a Cocoa application to work we need to have the Cocoa
-- event-loop running. Since we don't want to re-implement the
-- event-loop in Haskell, we simply dispatch to the Objective-C
-- version and hook into events.
--
-- This however, is not completely trivial, since calling the
-- long-running Objective-C loop causes Haskell code not to be
-- executed at all. Upon receiving an event we must also make
-- sure to dispatch to other Haskell threads in order to make
-- progress.
module Yi.UI.Cocoa.Application
( YiApplication
, _YiApplication
, YiController
, _YiController
, initializeClass_Application
, _eventChannel
, _runAction
, setAppleMenu
, ImpType_setAppleMenu
, pushClipboard
) where
import Prelude ()
import Yi.Prelude
import Control.Concurrent
import Control.Monad
import Data.Bits
import Yi.Editor
import Yi.Event
import Yi.UI.Cocoa.Utils
import Foreign.C
-- Specify Cocoa imports explicitly, to avoid name-clashes.
-- Since the number of functions recognized by HOC varies
-- between revisions, this seems like the safest choice.
import HOC
import Foundation (
NSObject,NSObjectClass,NSNotification,synchronize,_NSUserDefaults,
standardUserDefaults,_NSArray,arrayWithObject,haskellString,
_NSTimer,scheduledTimerWithTimeIntervalTargetSelectorUserInfoRepeats,
toNSString)
import AppKit (
NSEvent,NSMenu,NSApplication,NSApplicationClass,run,sendEvent,
applicationShouldTerminateAfterLastWindowClosed,_NSPasteboard,
applicationWillTerminate,generalPasteboard,availableTypeFromArray,
charactersIgnoringModifiers,declareTypesOwner,modifierFlags,
nsKeyDown,nsStringPboardType,setStringForType,changeCount,
stringForType,nsFlagsChanged)
foreign import ccall "RtsAPI.h shutdownHaskellAndExit" shutdownHaskellAndExit :: CInt -> IO ()
-- The selector is used since NSEvent#type treats the c enum
-- in a type-safe way, but Cocoa receives values which are not
-- defined in the c enum, which results in a pattern mismatch...
$(declareRenamedSelector "type" "rawType" [t| IO CInt |])
instance Has_rawType (NSEvent a)
-- This declares an application delegate which ensures the application
-- terminates when the last (and only) cocoa window is closed
$(declareClass "YiController" "NSObject")
$(exportClass "YiController" "yc_" [
InstanceMethod 'applicationShouldTerminateAfterLastWindowClosed -- '
, InstanceMethod 'applicationWillTerminate -- '
])
yc_applicationShouldTerminateAfterLastWindowClosed :: forall t. NSApplication t -> YiController () -> IO Bool
yc_applicationShouldTerminateAfterLastWindowClosed _app _self = return True
-- Since cocoa application termination is "optimized" by directly
-- calling exit, instead of falling out of the run-loop and returning
-- to haskell, we need to capture the termination and make sure that
-- we can run the haskell termination procedures.
-- Without this, profiling cannot be used with the cocoa frontend.
-- Unfortunately, graceful termination would require that haskell
-- and cocoa was first disconnected so that haskell code can be
-- properly terminated using hs_exit/shutdownHaskell. Once this is
-- done control can be left to cocoa to perform the final cocoa
-- cleanup. This solution can almost certainly not be implemented
-- from within haskell.
-- For the time being we try to gracefully terminate the haskell
-- portions and terminate the cocoa parts more forcefully. Any
-- "necessary" cocoa termination activities have to be replicated
-- below...
yc_applicationWillTerminate :: forall t. NSNotification t -> YiController () -> IO ()
yc_applicationWillTerminate _note _self = do
-- Partially replicate cocoa termination procedure
_NSUserDefaults # standardUserDefaults >>= synchronize
-- Interrupt cocoa and run haskell termination
shutdownHaskellAndExit 0
------------------------------------------------------------------------
-- This declares an application subclass which enables us to insert
-- ourselves into the application event loop and trap key-events application wide
$(declareClass "YiApplication" "NSApplication")
$(declareSelector "doTick" [t| IO () |])
$(declareSelector "setAppleMenu:" [t| forall t. NSMenu t -> IO () |] )
instance Has_setAppleMenu (NSApplication a)
$(exportClass "YiApplication" "ya_" [
InstanceVariable "eventChannel" [t| Maybe (Yi.Event.Event -> IO ()) |] [| Nothing |]
, InstanceVariable "runAction" [t| Maybe (EditorM () -> IO ()) |] [| Nothing |]
, InstanceVariable "lastPaste" [t| String |] [| "" |]
, InstanceVariable "lastChangeCount" [t| CInt |] [| 0 |]
, InstanceMethod 'run -- '
, InstanceMethod 'doTick -- '
, InstanceMethod 'sendEvent -- '
])
ya_doTick :: YiApplication () -> IO ()
ya_doTick slf = do
pb <- _NSPasteboard # generalPasteboard
cc <- pb # changeCount
oc <- slf #. _lastChangeCount
when (cc /= oc) $ do
slf # setIVar _lastChangeCount cc
ar <- _NSArray # arrayWithObject nsStringPboardType
ty <- pb # availableTypeFromArray (castObject ar)
when (ty /= nil) $ do
news <- pb # stringForType ty >>= haskellString
olds <- slf #. _lastPaste
when (news /= olds) $ do
slf # setIVar _lastPaste news
Just runAct <- slf #. _runAction
runAct (setRegE news)
replicateM_ 4 yield
pushClipboard :: String -> YiApplication () -> IO ()
pushClipboard news slf = do
olds <- slf #. _lastPaste
when (news /= olds) $ do
slf # setIVar _lastPaste news
ar <- _NSArray # arrayWithObject nsStringPboardType
pb <- _NSPasteboard # generalPasteboard
cc <- pb # declareTypesOwner (castObject ar) nil
pb # setStringForType (toNSString news) nsStringPboardType
slf # setIVar _lastChangeCount cc
return ()
ya_run :: YiApplication () -> IO ()
ya_run self = do
-- Schedule a timer that repeatedly invokes ya_doTick in order to have
-- some Haskell code running all the time. This will prevent other
-- Haskell threads to stall while waiting for the Cocoa run loop to finish.
_NSTimer # scheduledTimerWithTimeIntervalTargetSelectorUserInfoRepeats
0.05 self (getSelectorForName "doTick") nil True
super self # run
ya_sendEvent :: forall t. NSEvent t -> YiApplication () -> IO ()
ya_sendEvent event self = logNSException "sendEvent" $ do
t <- event # (rawType :: ImpType_rawType (NSEvent t) inst)
if t == fromCEnum nsKeyDown
then self #. _eventChannel >>= handleKeyEvent event
else if t == fromCEnum nsFlagsChanged
then do
logPutStrLn $ "Flags changed"
else super self # sendEvent event
handleKeyEvent :: forall t. NSEvent t -> Maybe (Yi.Event.Event -> IO ()) -> IO ()
handleKeyEvent event mch = do
mask <- event # modifierFlags
str <- event # charactersIgnoringModifiers >>= haskellString
logPutStrLn $ "Key " ++ str
let (mk,shift') = case str of
"\r" -> (Just KEnter, True)
"\t" -> (Just KTab, True)
"\DEL" -> (Just KBS, True)
"\ESC" -> (Just KEsc, True)
"\63232" -> (Just KUp, True)
"\63233" -> (Just KDown, True)
"\63234" -> (Just KLeft, True)
"\63235" -> (Just KRight, True)
"\63272" -> (Just KDel, True)
"\63273" -> (Just KHome, True)
"\63275" -> (Just KEnd, True)
"\63276" -> (Just KPageUp, True)
"\63277" -> (Just KPageDown, True)
[c] -> (Just $ KASCII c, False)
_ -> (Nothing, True)
case (mk,mch) of
(Just k, Just ch) -> ch (Event k (modifiers shift' mask))
_ -> return ()
modifierTable :: Bool -> [(CUInt, Modifier)]
modifierTable False = [(bit 18,MCtrl), (bit 19,MMeta), (bit 20,MSuper)]
modifierTable True = (bit 17,MShift) : modifierTable False
modifiers :: Bool -> CUInt -> [Modifier]
modifiers shift' mask = [yi | (cocoa, yi) <- modifierTable shift', (cocoa .&. mask) /= 0]
initializeClass_Application :: IO ()
initializeClass_Application = do
initializeClass_YiApplication
initializeClass_YiController