{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -- | HTk - a GUI toolkit for Haskell - (c) Universitaet Bremen -- ----------------------------------------------------------------------- module HTk.Kernel.Wish ( wish, evalTclScript, execTclScript, execCmd, evalCmd, -- escape, -- delimitString, Wish(..), TclCmd, TclScript, TclMessageType(..), BindTag, bindTagS, succBindTag, WishEvent(..), WishEventModifier(..), WishEventType(..), mkBoundCmdArg, KeySym(..), CallBackId(..), showP, requirePackage, -- :: String -> IO(Bool). Try to load a package. forgetPackage, -- :: String -> IO(). Forget a package. isPackageAvailable, -- :: String -> IO(Bool). True if package loaded. isTixAvailable, -- :: IO Bool. True if we are using tixwish, which -- means it was successfully loaded with requirePackage cleanupWish, delayWish, -- :: IO a -> IO a -- delayWish does an action, with the proviso that wish commands -- executed within the action by this or any other thread -- may be delayed. This can (allegedly) be faster. ) where -- The preprocessor symbol ASYNC_WISH_ERRORS, if non-zero, causes wish -- errors to be handled asynchronously. This is done by default unless DEBUG -- is set. -- This is an optimisation. The possible bad consequences are that should -- wish itself produce an error, -- (1) we may execute some additional wish commands before detecting it. -- (2) it is hard to associate the error with the command which provoked it. -- On the other hand, it saves us having to wait for acknowledgment of -- commands, which particularly on Windows (where we have to access wish output -- by polling with the current version of ghc, 5.02.2) should save a lot of -- time. #ifndef ASYNC_WISH_ERRORS #ifdef DEBUG #define ASYNC_WISH_ERRORS 0 #else #define ASYNC_WISH_ERRORS 1 #endif #endif import Data.List(union,delete) import Control.Concurrent import Foreign.C.String import System.IO.Unsafe import Control.Exception import Util.Object import Util.Computation import Events.Events import Events.GuardedEvents import Events.EqGuard import Events.Destructible import Events.Synchronized import Reactor.BSem import Reactor.InfoBus import Reactor.ReferenceVariables import HTk.Kernel.EventInfo import HTk.Kernel.GUIValue import HTk.Kernel.CallWish -- ----------------------------------------------------------------------- -- basic execution of Tcl commands -- ----------------------------------------------------------------------- --- -- evalCmd is used for commands which expect an answer, -- and calls evalTclScript. evalCmd :: TclCmd -> IO String evalCmd cmd = evalTclScript [cmd] --- -- Used for commands which expect an answer. evalTclScript :: TclScript -> IO String evalTclScript script = do let buffer = bufferedCommands wish -- (1) look at the buffer, execute the contents, and empty it. bufferContents <- takeMVar buffer case bufferContents of (0,_) -> putMVar buffer bufferContents (n,[]) -> putMVar buffer bufferContents (n,script) -> do putMVar buffer (n,[]) execCmdInner (reverse script) -- (2) execute the command response <- evalCmdInner script doResponse response --- -- execCmd is used for commands which don't expect an answer -- and calls execTclScript execCmd :: TclCmd -> IO () execCmd cmd = execTclScript [cmd] --- -- Used for commands which do not expect an answer execTclScript :: TclScript -> IO () execTclScript script = do let buffer = bufferedCommands wish bufferContents <- takeMVar buffer case bufferContents of (0,_) -> -- just do it do putMVar buffer (0,[]) execCmdInner script done (n,buffered) -> -- don't do it do let revAppend [] ys = ys revAppend (x:xs) ys = revAppend xs (x:ys) putMVar buffer (n,revAppend script buffered) --- -- delayWish does an action, with the proviso that wish commands -- executed within the action by this or any other thread -- may be delayed. This can (allegedly) be faster. delayWish :: IO a -> IO a delayWish action = do beginBuffering tried <- Control.Exception.try action endBuffering propagate tried --- -- beginBuffering begins buffering commands (if we aren't already). beginBuffering :: IO () beginBuffering = do let buffer = bufferedCommands wish bufferContents <- takeMVar buffer case bufferContents of (n,script) -> putMVar buffer (n+1,script) --- -- unbuffercommands undoes a beginBuffering, and flushes the current buffer. endBuffering :: IO () endBuffering = do let buffer = bufferedCommands wish bufferContents <- takeMVar buffer case bufferContents of (n,script) -> do execCmdInner (reverse script) putMVar buffer (n-1,[]) --- -- evalCmdInner takes a (possibly empty) TclScript and executes it, -- returning a response. It does not look at the buffer, so should -- not be called from outside. evalCmdInner :: TclScript -> IO TclResponse evalCmdInner [] = return (OK "") evalCmdInner tclScript = do let scriptString = foldr1 (\ cmd s -> cmd ++ (';':s)) tclScript cmdString = "evS " ++ escape scriptString ++"\n" withCStringLen cmdString evalCmdPrim --- -- This is the most primitive command evaluator and does not -- look at the buffer. So it shouldn't be called from outside. evalCmdPrim :: CStringLen -> IO TclResponse evalCmdPrim cStringLen = do let rWish = readWish wish wWish = writeWish wish synchronize (wishLock wish) ( do wWish cStringLen sync( toEvent (rWish |> Eq OKType) >>>= (\ (_,okString) -> return (OK okString)) #if ! ASYNC_WISH_ERRORS +> toEvent (rWish |> Eq ERType) >>>= (\ (_,erString) -> return (ER erString)) #endif ) ) #if ASYNC_WISH_ERRORS --- -- execCmdInner corresponds to evalCmdInner, but does not return a response. execCmdInner :: TclScript -> IO () execCmdInner [] = done execCmdInner tclScript = do let scriptString = foldr1 (\ cmd s -> cmd ++ (';':s)) tclScript cmdString = "exS " ++ escape scriptString ++"\n" -- The difference is we call "exS" and not "evS". withCStringLen cmdString execCmdPrim --- -- execCmdPrim corresponds to evalCmdPrim, but does not wait for a response. execCmdPrim :: CStringLen -> IO () execCmdPrim cStringLen = writeWish wish cStringLen #else execCmdInner :: TclScript -> IO () execCmdInner script = do response <- evalCmdInner script doResponse1 response done #endif doResponse :: TclResponse -> IO String doResponse (OK res) = return res #if ! ASYNC_WISH_ERRORS doResponse (ER err) = error err #endif doResponse1 :: TclResponse -> IO () doResponse1 (OK res) = return () #if ! ASYNC_WISH_ERRORS doResponse1 (ER err) = do fingersCrossed err done #endif fingersCrossed :: String -> IO () fingersCrossed err = putStrLn ("Unexpected error " ++ err ++ " returned from wish\n" ++ "Continuing, with fingers crossed") -- ----------------------------------------------------------------------- -- wish datatypes -- ----------------------------------------------------------------------- data Wish = Wish { wishLock :: BSem, -- this locks wish when a command has been sent but not answer -- received, as yet. eventQueue :: EqGuardedChannel BindTag EventInfo, -- Wish puts events here, parameterised by the -- widget tag, which for us is always a widget id. -- The events will be taken off by the event dispatcher. coQueue :: EqGuardedChannel CallBackId (), -- CO events, produced by the relay command, go here. -- (These are used for Widgets with actions attached, -- EG for buttons with "Click me" on them.), -- callBackIds :: MVar CallBackId, bindTags :: MVar BindTag, readWish :: GuardedEvent (EqMatch TclMessageType) (TclMessageType,String), -- Wish output sorted by prefix. writeWish :: CStringLen -> IO (), -- Command to execute a Wish command. destroyWish :: IO (), -- Command to destroy this Wish instance. bufferedCommands :: MVar (Int,TclScript), -- The integer indicates if buffering is going on. -- If non-zero it is. When we start new buffering, we -- increment the integer. -- The TclScript contains the current contents of the buffer -- IN REVERSE ORDER. -- If the integer is 0, the TclScript is []. oID :: ObjectID } type TclCmd = String type TclScript = [TclCmd] #if ASYNC_WISH_ERRORS newtype TclResponse = OK String #else data TclResponse = OK String | ER String #endif data TclMessageType = OKType | ERType | COType | EVType deriving (Eq,Ord,Show) -- ---------------------------------------------------------------- -- wish instances -- ---------------------------------------------------------------- instance Object Wish where objectID wish = oID wish instance Destroyable Wish where destroy wish = destroyWish wish -- ---------------------------------------------------------------- -- running the wish -- ---------------------------------------------------------------- wish :: Wish wish = unsafePerformIO newWish {-# NOINLINE wish #-} cleanupWish :: IO () cleanupWish = destroy wish newWish :: IO Wish newWish = do calledWish <- callWish let writeWish = sendCalledWish calledWish -- Set up initial wish procedures. wishHeader = "proc ConvertTkValue val {" ++ -- The "regsub" commands replace \ by \\ and newline by \\. "regsub -all {\\\\} $val {\\\\\\\\} res1;" ++ "regsub -all \\n $res1 {\\\\n} res;" ++ "return $res" ++ "};" ++ -- Execute the command, returning the result. "proc evS x {" ++ "set status [catch {eval $x} res];" ++ "set val [ConvertTkValue $res];" ++ "if {$status == 0} {puts \"OK $val\"} else {puts \"ER $val\"}" ++ "};" ++ #if ASYNC_WISH_ERRORS -- Execute the command, not returning the result. "proc exS x {" ++ "set status [catch {eval $x} res];" ++ "if {$status} {puts [concat \"EX \" [ConvertTkValue $res]]}" ++ "};" ++ #endif "proc relay {evId val} {" ++ "set res [ConvertTkValue $val];" ++ "puts \"CO $evId $res\"" ++ "};" ++ -- The following Tcl functions adds and removes bindings for -- a widget. -- ldelete deletes an item from a list -- (Stolen from Tcl book page 58) "proc ldelete {list value} {" ++ "set ix [lsearch -exact $list $value];" ++ "if {$ix >=0 } {" ++ "return [lreplace $list $ix $ix]" ++ "} else {return $list}};" ++ -- addtag adds a bind tag for a widget "proc addtag {widget tag} {" ++ "set x [bindtags $widget];" ++ "lappend x $tag;" ++ "bindtags $widget $x};" ++ -- rmtag removes a bind tag from a widget "proc rmtag {widget tag} {" ++ "bindtags $widget [ldelete [bindtags $widget] $tag]}\n" withCStringLen wishHeader writeWish -- get readWish reactor going. (readWish,destroyReadWish) <- readWishEvent calledWish -- set up the channels wishLock <- newBSem eventQueue <- newEqGuardedChannel coQueue <- newEqGuardedChannel bindTags <- newMVar nullBindTag let destroyWish1 = do destroyReadWish destroyCalledWish calledWish -- Wish reactor will be garbage collected. destroyWish <- doOnce destroyWish1 bufferedCommands <- newMVar (0,[]) oID <- newObject let wish = Wish { wishLock = wishLock, eventQueue = eventQueue, coQueue = coQueue, bindTags = bindTags, readWish = readWish, writeWish = writeWish, destroyWish = destroyWish, bufferedCommands = bufferedCommands, oID = oID } _ <- spawnEvent eventForwarder registerToolDebug "Wish" wish -- so that shutdown works. return wish eventForwarder :: Event () eventForwarder = forever handleEvent where rWish = readWish wish -- event that passes on EV and CO events. handleEvent :: Event () handleEvent = (do -- Pass on ev events. (_,evString) <- toEvent (rWish |> Eq EVType) noWait(send (eventQueue wish) (parseEVString evString)) ) +> (do -- Handle co events (_,coString) <- toEvent (rWish |> Eq COType) noWait(send (coQueue wish) (parseCallBack coString)) ) #if ASYNC_WISH_ERRORS +> (do -- Handle wish errors (_,erString) <- toEvent (rWish |> Eq ERType) always (fingersCrossed erString) ) #endif readWishEvent :: CalledWish -> IO (GuardedEvent (EqMatch TclMessageType) (TclMessageType,String), IO()) readWishEvent calledWish = do wishInChannel <- newEqGuardedChannel destroy <- spawnEvent(forever( do next <- always (Control.Exception.catch (readCalledWish calledWish) (\ (_ :: SomeException) -> return "OK Terminated")) send wishInChannel (typeWishAnswer next) )) return (listen wishInChannel,destroy) -- typeWishAnswer parses answers from Wish. -- The format of messages from Wish, after we've defined the first -- few procedures, is -- OK [escaped string] -- for a successfully completed command with this result. -- ER [escaped string] -- for an unsuccessful command with this result. -- CO [escaped string] -- for an output of the "relay" procedure, which we use in commands -- attached to Tcl widgets. (EG it might be the text the user -- has typed into a text widget.) -- We will break this up further with splitCO, which expects to -- find a space. -- EV [non-escaped string] -- for an event. This is set up by the bind command in -- TkCommands.hs. (We don't need to escape this as it can't -- contain funny characters.) -- We parse this, unescaping the Strings where necessary. typeWishAnswer :: String -> (TclMessageType,String) -- typeWishAnswer returns the type, and the unescaped String. typeWishAnswer str = case str of 'O':'K':' ':rest -> (OKType,unEscape rest) 'E':'R':' ':rest -> (ERType,unEscape rest) 'C':'O':' ':rest -> (COType,unEscape rest) 'E':'V':' ':rest -> (EVType,rest) _ -> parseError str where unEscape "" = "" unEscape ('\\':'n':rest) = '\n':unEscape rest unEscape ('\\':'\\':rest) = '\\':unEscape rest unEscape ('\\':_:rest) = parseError str unEscape (ch:rest) =ch:unEscape rest parseError :: String -> a parseError str = error ("Wish: couldn't parse wish response "++ (show str)) -- ----------------------------------------------------------------------- -- Interface to wish packages -- ----------------------------------------------------------------------- loadedPackages :: Ref [String] loadedPackages = unsafePerformIO (newRef []) {-# NOINLINE loadedPackages #-} -- Require a package, returning flag for success requirePackage :: String -> IO (Bool) requirePackage package = do response <- evalCmd ("package require " ++ package) if response == ("can't find package " ++ package) then return False else do loaded <- getRef loadedPackages setRef loadedPackages ([package] `union` loaded) return True forgetPackage :: String -> IO () forgetPackage package = do evalCmd ("package forget " ++ package) loaded <- getRef loadedPackages setRef loadedPackages (delete package loaded) return () -- isPackageAvailable is used to determine if a package is loaded -- (must use requirePackage to load it first, if desired) isPackageAvailable :: String -> IO Bool isPackageAvailable package = do loaded <- getRef loadedPackages return (package `elem` loaded) -- isTixAvailable is used to determine if Tix is available . . . isTixAvailable :: IO Bool isTixAvailable = isPackageAvailable "Tix" -- ----------------------------------------------------------------------- -- BindCmd and its cousins -- ----------------------------------------------------------------------- newtype BindTag = BindTag Int deriving (Eq,Ord) bindTagS :: BindTag -> String bindTagS (BindTag i) = show i bindTagR :: String -> BindTag bindTagR str = case reads str of [(i,"")] -> BindTag i _ -> error ("Can't parse bind tag "++str++".") nullBindTag :: BindTag nullBindTag = BindTag 0 succBindTag :: BindTag -> BindTag succBindTag (BindTag n) = BindTag (n+1) -- ----------------------------------------------------------------------- -- Bind Event Data -- ----------------------------------------------------------------------- -- We do not allow general Bind commands. All bind commands simply -- put the result to stdout in the following format: -- "EV [bindTag]( [id][value])*" -- where -- [bindTag] is our tag for the binding. -- [id] is a single character identifying the information -- [value] is the String value -- In the above, (...)* means that the syntax within brackets can be -- repeated any number n>=0 times. -- We also assume that all the strings ([widgetTag], [String]) do not -- contain any spaces funny escape characters. This can be deduced from -- page 298 and the fact that bindTags are in fact just going to -- be lists of numbers separated by period. mkBoundCmdArg :: BindTag -> EventInfoSet -> Bool-> String -- Make the command to be passed as ?bindstr? for "bi". -- (See notes at the head of this section.) -- Adding a "break" statement behind the puts prevents the binding from being -- processed further. That means we override earlier/default bindings. mkBoundCmdArg bindTag eventInfoSet break = let bindStr = "EV " ++ bindTagS bindTag ++ foldr (\ par soFar -> let tag = epToChar par in ' ':tag:'%':tag:soFar) "" (listEventInfoSet eventInfoSet) in "{puts " ++ (delimitString bindStr) ++ if break then "; break}" else "}" parseEVString :: String -> (BindTag,EventInfo) -- parseEVString parses the resulting String, EXCEPT for the -- initial "EV ", which are stripped off before they get this far. parseEVString str = let bindTagStr:settings = words str eventInfo = mkEventInfo (map (\ (tag:rest) -> (epFromChar tag,rest)) settings) in (bindTagR bindTagStr,eventInfo) -- ----------------------------------------------------------------------- -- Wish events -- These also have to implement Eq and Ord for the benefit of -- the Widget dispatcher, which needs to handle finite maps on them. -- NB - we won't encourage people to get hold of Wish's current -- name for an event, since this is hard to reconcile to our -- encapsulation (EG it probably involves detailed knowledge of -- local keysyms to do it properly). -- ----------------------------------------------------------------------- data WishEvent = WishEvent [WishEventModifier] WishEventType deriving (Ord,Eq) instance Show WishEvent where -- We specify that the resulting String is already escaped -- as necessary. showsPrec _ (WishEvent modifiers wishEventType) acc = '<' : (foldr (\ modifier soFar -> showP modifier ('-':soFar)) (typeToStringP wishEventType ('>':acc)) modifiers ) -- page 290 except that we merge keysyms (page 291) into the KeyPress and -- KeyRelease type. data WishEventType = Activate | ButtonPress (Maybe BNo) | ButtonRelease (Maybe BNo) | Circulate | Colormap | Configure | Deactivate | Destroy | Enter | Expose | FocusIn | FocusOut | Gravity | KeyPress (Maybe KeySym) | KeyRelease (Maybe KeySym)| Motion | Leave | Map | Property | Reparent | Unmap | Visibility deriving (Show,Eq,Ord) -- the Show instance won't work for KeySyms, so we fix up later newtype KeySym = KeySym String deriving (Show,Ord,Eq) -- A KeySym can be a single character representing a key. However others -- are defined, and depend on the window implementation. For example, -- on this machine the Return key is called "Return", and the -- Enter key "KP_Enter". Page291 has a wish binding for determining -- the keysym for a key. -- The KeySym is escaped as necessary before being fed to Wish; -- for example KeySym ['\n'] works. ksToStringP :: Maybe KeySym -> String -> String ksToStringP Nothing acc = acc ksToStringP (Just (KeySym keySym)) acc = '-':((escapeString keySym)++acc) type BNo = Int -- used for buttons bNoToStringP :: Maybe BNo -> String -> String bNoToStringP Nothing acc = acc bNoToStringP (Just bNo) acc = '-':(showP bNo acc) typeToStringP :: WishEventType -> String -> String typeToStringP (ButtonPress bNo) acc = "ButtonPress" ++ (bNoToStringP bNo acc) typeToStringP (ButtonRelease bNo) acc = "ButtonRelease" ++ (bNoToStringP bNo acc) typeToStringP (KeyPress ks) acc = "KeyPress" ++ (ksToStringP ks acc) typeToStringP (KeyRelease ks) acc = "KeyRelease" ++ (ksToStringP ks acc) typeToStringP other acc = showP other acc -- page 294 -- We rename "Command" "CommandKey" to avoid conflicts with the -- Command attribute. data WishEventModifier = Control | Shift | Lock | CommandKey | Meta | M | Alt | Mod1 | Mod2 | Mod3 | Mod4 | Mod5 | Button1 | Button2 | Button3 | Button4 | Button5 | Double | Triple deriving (Show,Ord,Eq) -- ----------------------------------------------------------------------- -- CallBackId's identify callbacks. -- ----------------------------------------------------------------------- newtype CallBackId = CallBackId ObjectID deriving (Eq,Ord,Show) parseCallBack :: String -> (CallBackId, ()) parseCallBack str = case reads str of [(i, _)] -> (CallBackId i, ()) _ -> error ("Couldn't parse Wish callback "++str) showCallBackId :: CallBackId -> String showCallBackId (CallBackId nm) = show nm -- ----------------------------------------------------------------------- -- General abbreviations -- ----------------------------------------------------------------------- -- Like toTkString, except it only places quotes if necessary escape :: String-> String escape = delimitString . escapeString -- Convenient abbreviation showP :: Show a => a -> String -> String showP val acc = showsPrec 0 val acc