module HTk.Kernel.Wish (
wish,
evalTclScript,
execTclScript,
execCmd,
evalCmd,
Wish(..),
TclCmd,
TclScript,
TclMessageType(..),
BindTag,
bindTagS,
succBindTag,
WishEvent(..),
WishEventModifier(..),
WishEventType(..),
mkBoundCmdArg,
KeySym(..),
CallBackId(..),
showP,
requirePackage,
forgetPackage,
isPackageAvailable,
isTixAvailable,
cleanupWish,
delayWish,
) where
#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
evalCmd :: TclCmd -> IO String
evalCmd cmd = evalTclScript [cmd]
evalTclScript :: TclScript -> IO String
evalTclScript script =
do
let buffer = bufferedCommands wish
bufferContents <- takeMVar buffer
case bufferContents of
(0,_) -> putMVar buffer bufferContents
(n,[]) -> putMVar buffer bufferContents
(n,script) ->
do
putMVar buffer (n,[])
execCmdInner (reverse script)
response <- evalCmdInner script
doResponse response
execCmd :: TclCmd -> IO ()
execCmd cmd = execTclScript [cmd]
execTclScript :: TclScript -> IO ()
execTclScript script =
do
let buffer = bufferedCommands wish
bufferContents <- takeMVar buffer
case bufferContents of
(0,_) ->
do
putMVar buffer (0,[])
execCmdInner script
done
(n,buffered) ->
do
let
revAppend [] ys = ys
revAppend (x:xs) ys = revAppend xs (x:ys)
putMVar buffer (n,revAppend script buffered)
delayWish :: IO a -> IO a
delayWish action =
do
beginBuffering
tried <- Control.Exception.try action
endBuffering
propagate tried
beginBuffering :: IO ()
beginBuffering =
do
let buffer = bufferedCommands wish
bufferContents <- takeMVar buffer
case bufferContents of
(n,script) -> putMVar buffer (n+1,script)
endBuffering :: IO ()
endBuffering =
do
let buffer = bufferedCommands wish
bufferContents <- takeMVar buffer
case bufferContents of
(n,script) ->
do
execCmdInner (reverse script)
putMVar buffer (n1,[])
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
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 :: TclScript -> IO ()
execCmdInner [] = done
execCmdInner tclScript =
do
let
scriptString = foldr1 (\ cmd s -> cmd ++ (';':s)) tclScript
cmdString = "exS " ++ escape scriptString ++"\n"
withCStringLen cmdString execCmdPrim
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")
data Wish = Wish {
wishLock :: BSem,
eventQueue :: EqGuardedChannel BindTag EventInfo,
coQueue :: EqGuardedChannel CallBackId (),
bindTags :: MVar BindTag,
readWish ::
GuardedEvent (EqMatch TclMessageType) (TclMessageType,String),
writeWish :: CStringLen -> IO (),
destroyWish :: IO (),
bufferedCommands :: MVar (Int,TclScript),
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)
instance Object Wish where
objectID wish = oID wish
instance Destroyable Wish where
destroy wish = destroyWish wish
wish :: Wish
wish = unsafePerformIO newWish
cleanupWish :: IO ()
cleanupWish = destroy wish
newWish :: IO Wish
newWish =
do
calledWish <- callWish
let
writeWish = sendCalledWish calledWish
wishHeader =
"proc ConvertTkValue val {" ++
"regsub -all {\\\\} $val {\\\\\\\\} res1;" ++
"regsub -all \\n $res1 {\\\\n} res;" ++
"return $res" ++
"};" ++
"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
"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\"" ++
"};" ++
"proc ldelete {list value} {" ++
"set ix [lsearch -exact $list $value];" ++
"if {$ix >=0 } {" ++
"return [lreplace $list $ix $ix]" ++
"} else {return $list}};" ++
"proc addtag {widget tag} {" ++
"set x [bindtags $widget];" ++
"lappend x $tag;" ++
"bindtags $widget $x};" ++
"proc rmtag {widget tag} {" ++
"bindtags $widget [ldelete [bindtags $widget] $tag]}\n"
withCStringLen wishHeader writeWish
(readWish,destroyReadWish) <- readWishEvent calledWish
wishLock <- newBSem
eventQueue <- newEqGuardedChannel
coQueue <- newEqGuardedChannel
bindTags <- newMVar nullBindTag
let
destroyWish1 =
do
destroyReadWish
destroyCalledWish calledWish
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
return wish
eventForwarder :: Event ()
eventForwarder = forever handleEvent
where
rWish = readWish wish
handleEvent :: Event ()
handleEvent =
(do
(_,evString) <- toEvent (rWish |> Eq EVType)
noWait(send (eventQueue wish) (parseEVString evString))
)
+> (do
(_,coString) <- toEvent (rWish |> Eq COType)
noWait(send (coQueue wish) (parseCallBack coString))
)
#if ASYNC_WISH_ERRORS
+> (do
(_,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 :: String -> (TclMessageType,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))
loadedPackages :: Ref [String]
loadedPackages = unsafePerformIO (newRef [])
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 :: String -> IO Bool
isPackageAvailable package =
do loaded <- getRef loadedPackages
return (package `elem` loaded)
isTixAvailable :: IO Bool
isTixAvailable = isPackageAvailable "Tix"
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)
mkBoundCmdArg :: BindTag -> EventInfoSet -> Bool-> String
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 str =
let
bindTagStr:settings = words str
eventInfo = mkEventInfo
(map (\ (tag:rest) -> (epFromChar tag,rest)) settings)
in
(bindTagR bindTagStr,eventInfo)
data WishEvent = WishEvent [WishEventModifier] WishEventType
deriving (Ord,Eq)
instance Show WishEvent where
showsPrec _ (WishEvent modifiers wishEventType) acc =
'<' :
(foldr
(\ modifier soFar -> showP modifier ('-':soFar))
(typeToStringP wishEventType ('>':acc))
modifiers
)
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)
newtype KeySym = KeySym String deriving (Show,Ord,Eq)
ksToStringP :: Maybe KeySym -> String -> String
ksToStringP Nothing acc = acc
ksToStringP (Just (KeySym keySym)) acc =
'-':((escapeString keySym)++acc)
type BNo = Int
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
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)
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
escape :: String-> String
escape = delimitString . escapeString
showP :: Show a => a -> String -> String
showP val acc = showsPrec 0 val acc