diff --git a/AppleScript.cabal b/AppleScript.cabal --- a/AppleScript.cabal +++ b/AppleScript.cabal @@ -1,25 +1,50 @@ Name: AppleScript -Version: 0.1.5 +Version: 0.2 License: BSD3 License-file: LICENSE -Author: Wouter Swierstra -Maintainer: Wouter Swierstra -Synopsis: Call AppleScript from Haskell. -Description: This package enables you to compile and - execute AppleScript from Haskell applications. +Author: Wouter Swierstra , Reiner Pope +Maintainer: Reiner Pope +homepage: https://github.com/reinerp/haskell-AppleScript +bug-reports: https://github.com/reinerp/haskell-AppleScript/issues +Synopsis: Call AppleScript from Haskell, and then call back into Haskell. +Description: + This package enables you to compile and execute AppleScript code from + Haskell, and provides support for this AppleScript code to call back + into Haskell. To get started, see "Foreign.AppleScript.Rich". Category: Foreign Extra-source-files: examples/HelloThere.hs , examples/OpenLocation.hs - , examples/TextFields.hs + , examples/Plain.hs + , examples/Rich.hs + , examples/RuntimeError.hs + , examples/SyntaxError.hs , cbits/RunScript.h Build-type: Simple -Cabal-Version: >= 1.2 && < 2 +Cabal-Version: >= 1.6 +source-repository head + type: git + location: git://github.com/reinerp/haskell-AppleScript.git + Library { if os(darwin) { Buildable: True - Build-Depends: base >= 2 && < 5 - Exposed-modules: Foreign.AppleScript + Build-Depends: base >= 2 && < 5, + bytestring < 0.10, + data-default < 0.4, + text < 0.12, + haskell-src-meta >= 0.5.0.3 && < 0.6, + text-format < 0.4, + network < 2.4, + conduit < 0.3, + directory < 1.2, + template-haskell == 2.7.*, + mtl == 2.0.* + Exposed-modules: + Foreign.AppleScript + Foreign.AppleScript.Error + Foreign.AppleScript.Plain + Foreign.AppleScript.Rich Frameworks: Carbon Extensions: CPP, ForeignFunctionInterface Include-Dirs: cbits diff --git a/Foreign/AppleScript.hs b/Foreign/AppleScript.hs --- a/Foreign/AppleScript.hs +++ b/Foreign/AppleScript.hs @@ -1,44 +1,8 @@ -- | A module that enables you to compile and execute AppleScript. -module Foreign.AppleScript +module Foreign.AppleScript ( - appleScriptAvailable, - execAppleScript + module Foreign.AppleScript.Rich, ) where -import System.Exit -import Foreign -import Foreign.C - - -type OSStatus = Int32 -data AEDesc = AEDesc - -foreign import ccall "RunScript.h LowRunAppleScript" - cLowRunAppleScript :: CString -> CLong -> Ptr AEDesc -> IO OSStatus - --- | The 'appleScriptAvailable' function checks whether or not AppleScript is --- available on your platform. -foreign import ccall "RunScript.h AppleScriptAvailable" appleScriptAvailable :: IO Bool - --- | The 'execAppleScript' function will attempt to compile and --- execute the AppleScript, described in the @String@ it receives as --- its argument. Any result of running the script is discarded. The --- @ExitCode@ indicates whether or not any errors were encountered --- during compilation or execution. -execAppleScript :: String -> IO ExitCode -execAppleScript script = do - let run (cstr,len) = cLowRunAppleScript cstr (fromIntegral len) nullPtr - osstatus <- withCStringLen script run - return (fromOSStatus osstatus) - --- Not the world's finest functions... -noErr :: Int32 -noErr = 0 - -fromOSStatus :: Int32 -> ExitCode -fromOSStatus n - | n == noErr = ExitSuccess - | otherwise = ExitFailure (fromIntegral n) - - +import Foreign.AppleScript.Rich diff --git a/Foreign/AppleScript/Error.hs b/Foreign/AppleScript/Error.hs new file mode 100644 --- /dev/null +++ b/Foreign/AppleScript/Error.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} + +module Foreign.AppleScript.Error where + +import System.Exit +import Control.Exception +import Data.Typeable +import qualified Data.Text.Lazy as Text +import Data.Text.Format + +-- | AppleScript signaled an error. +data AppleScriptError = + AppleScriptError + { exitCode :: !Int, + message :: !(Maybe Text.Text) + } + deriving(Typeable) + +instance Show AppleScriptError where + show (AppleScriptError c mt) = case mt of + Nothing -> Text.unpack $ format "AppleScript error code {}" (Only c) + Just t -> Text.unpack $ format "AppleScript error (code {}): {}" (c, t) + +instance Exception AppleScriptError + +-- | AppleScript didn't return a value which could be coerced to text. +data AppleScriptNoReturn = AppleScriptNoReturn + deriving(Typeable) + +instance Show AppleScriptNoReturn where + show AppleScriptNoReturn = "AppleScript didn't return a value which could be coerced to text" + +instance Exception AppleScriptNoReturn + +-- | On success, returns; otherwise throws 'AppleScriptError'. +ignoreResultOrThrow :: IO (ExitCode, Maybe Text.Text) -> IO () +ignoreResultOrThrow mv = do + v <- mv + case v of + (ExitSuccess, _) -> return () + (ExitFailure c, mt) -> throwIO $ AppleScriptError c mt + +-- | On success, extracts the message; otherwise throws 'AppleScriptError' or 'AppleScriptNoReturn', as appropriate. +extractResultOrThrow :: IO (ExitCode, Maybe Text.Text) -> IO Text.Text +extractResultOrThrow mv = do + v <- mv + case v of + (ExitSuccess, Just t) -> return t + (ExitSuccess, Nothing) -> throwIO AppleScriptNoReturn + (ExitFailure c, mt) -> throwIO $ AppleScriptError c mt diff --git a/Foreign/AppleScript/Plain.hs b/Foreign/AppleScript/Plain.hs new file mode 100644 --- /dev/null +++ b/Foreign/AppleScript/Plain.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving #-} +-- | Module for running plain AppleScript. For a richer interface, see "Foreign.AppleScript.Rich". +-- +-- A complete example using this module: +-- +-- > {-# LANGUAGE QuasiQuotes #-} +-- > import Foreign.AppleScript.Plain +-- > import qualified Data.Text.Lazy.IO as Text +-- > +-- > main = Text.putStrLn =<< evalScript [applescript| +-- > tell application "System Events" +-- > display dialog "Hello World!" +-- > +-- > -- Unicode support +-- > return "Viele Grüße von AppleScript!" +-- > end tell +-- > |] +module Foreign.AppleScript.Plain( + appleScriptAvailable, + runScript, + evalScript, + runScriptFull, + applescript, + AppleScript(..), + ) where + +import Data.String +import Language.Haskell.TH.Quote + +import Control.Exception +import Control.Applicative +import System.Exit + +import Foreign +import Foreign.C +import Foreign.AppleScript.Error + +import Data.Text.Encoding(decodeUtf8, encodeUtf8) +import qualified Data.Text.Lazy.IO as Text +import qualified Data.Text.Lazy as Text +import Data.Text.Lazy(Text, isPrefixOf) +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.ByteString as BS + +type OSStatus = Int32 +data AEDesc = AEDesc + +foreign import ccall unsafe "RunScript.h _hs_AEDescSize" + aeDescSize :: CSize +foreign import ccall unsafe "RunScript.h _hs_initNull" + initNull :: Ptr AEDesc -> IO () +foreign import ccall unsafe "RunScript.h _hs_getUTF8Size" + getUtf8Size :: Ptr AEDesc -> IO CPtrdiff +foreign import ccall unsafe "RunScript.h _hs_getData" + getData :: Ptr AEDesc -> Ptr a -> CSize -> IO OSStatus +foreign import ccall unsafe "RunScript.h _hs_dispose" + dispose :: Ptr AEDesc -> IO OSStatus + +withAEDesc :: (Ptr AEDesc -> IO a) -> IO a +withAEDesc f = + allocaBytes (fromIntegral aeDescSize) $ \aeptr -> + bracket (initNull aeptr) (\_ -> dispose aeptr) $ \_ -> + f aeptr + +extractStringData :: Ptr AEDesc -> IO (Maybe Text) +extractStringData aedesc = do + size <- getUtf8Size aedesc + case size of + -1 -> return Nothing + _ -> allocaBytes (fromIntegral size) $ \dat -> do + err <- getData aedesc dat (fromIntegral size) + case err == noErr of + False -> return Nothing + True -> (Just . Text.fromStrict . decodeUtf8) <$> BS.packCStringLen (dat, fromIntegral size) + +foreign import ccall "RunScript.h LowRunAppleScript" + cLowRunAppleScript :: CString -> CLong -> Ptr AEDesc -> IO OSStatus + +-- | The 'appleScriptAvailable' function checks whether or not AppleScript is +-- available on your platform. +foreign import ccall "RunScript.h AppleScriptAvailable" appleScriptAvailable :: IO Bool + +newtype AppleScript = AppleScript { unAppleScript :: Text } + deriving(IsString) + +-- | Run the script using 'runScriptFull', throwing an exception on failure. +-- Ignores the script's result value. +runScript :: AppleScript -> IO () +runScript script = ignoreResultOrThrow (runScriptFull script) + +-- | Run the script using 'runScriptFull', throwing an exception on +-- failure. Returns the script's result value, coerced to text. +-- +-- See "Foreign.AppleScript.Error" for the possible exceptions. +evalScript :: AppleScript -> IO Text +evalScript script = extractResultOrThrow (runScriptFull script) + +-- | The 'execAppleScript' function will attempt to compile and +-- execute the AppleScript, described in the @String@ it receives as +-- its argument. Any result of running the script is discarded. The +-- @ExitCode@ indicates whether or not any errors were encountered +-- during compilation or execution. +runScriptFull :: AppleScript -> IO (ExitCode, Maybe Text) +runScriptFull (AppleScript script) = withAEDesc $ \aedesc -> do + let run (cstr,len) = cLowRunAppleScript cstr (fromIntegral len) aedesc + osstatus <- BS.useAsCStringLen (encodeUtf8 . Text.toStrict $ script) run + mstr <- extractStringData aedesc + return (fromOSStatus osstatus, mstr) + +-- Not the world's finest functions... +noErr :: Int32 +noErr = 0 + +fromOSStatus :: Int32 -> ExitCode +fromOSStatus n + | n == noErr = ExitSuccess + | otherwise = ExitFailure (fromIntegral n) + + +{- | +Unescaped 'AppleScript', useful for AppleScript programs. See the +example at the top of this module. +-} +applescript :: QuasiQuoter +applescript = QuasiQuoter{quoteExp=driver, quotePat=undefined, quoteType=undefined, quoteDec=undefined} + where + driver string = [| AppleScript (Text.pack string) |] diff --git a/Foreign/AppleScript/Rich.hs b/Foreign/AppleScript/Rich.hs new file mode 100644 --- /dev/null +++ b/Foreign/AppleScript/Rich.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE + TemplateHaskell, + OverloadedStrings, + ExistentialQuantification, + ViewPatterns, + TupleSections, + TypeSynonymInstances, + FlexibleInstances + #-} +{-# OPTIONS_GHC -funbox-strict-fields -Wall -Werror #-} + +-- | +-- This module supports a \"rich\" communication with AppleScript. Specifically, this +-- module provides support for AppleScript calling back into Haskell, as well as splicing +-- Haskell values into AppleScript code. +-- +-- Here is an example which demonstrates the provided features. +-- +-- > {-# LANGUAGE QuasiQuotes #-} +-- > import Foreign.AppleScript.Rich +-- > import qualified Data.Text.Lazy as Text +-- > import qualified Data.Text.Lazy.IO as Text +-- > +-- > main = Text.putStrLn =<< evalScript mainScript +-- > +-- > mainScript = [applescript| +-- > tell application "System Events" +-- > -- Haskell value splices, and Unicode support. +-- > display dialog "The value of π is $value{pi :: Double}$." +-- > +-- > -- AppleScript can call back into Haskell. +-- > set yourName to text returned of (display dialog "What is your name?" default answer "") +-- > display dialog ("Your name in reverse is " & $callback{ \t -> return (Text.reverse t) }$[ yourName ]$) +-- > +-- > -- Splice other AppleScript code into here +-- > $applescript{ othergreeter }$ +-- > +-- > -- Return text from AppleScript back to Haskell +-- > return "Hello from AppleScript!" +-- > end tell +-- > |] +-- > +-- > othergreeter = [applescript| +-- > display dialog "Hello from the other greeter!" +-- > |] +-- +-- The quasiquoter is +module Foreign.AppleScript.Rich + ( + -- * Common-use functions + Plain.appleScriptAvailable, + applescript, + runScript, + evalScript, + debugScript, + runScriptFull, + -- * Syntax tree + AppleScript(..), + AppleScriptElement(..), + AppleScriptValue(..), + -- * Configuration + AppleScriptConfig(..), + def, + ) + where + +import Foreign.AppleScript.Error +import qualified Foreign.AppleScript.Plain as Plain + +import Control.Applicative +import Control.Monad.State +import Control.Monad.Writer +import Control.Monad.Trans.Resource(ResourceT, runResourceT, withIO) + +import Control.Exception(tryJust, finally) +import Control.Concurrent(forkIO, killThread) + +import System.IO +import System.IO.Error(ioeGetErrorType) +import System.IO.Unsafe(unsafePerformIO) +import GHC.IO.Exception(IOErrorType(InvalidArgument)) + +import System.Exit + +import Network(accept, listenOn, sClose, PortID(..), PortNumber) + +import Data.List(minimumBy) +import Data.Ord(comparing) +import Data.IORef +import Data.Default + +import Data.Text.Lazy(Text, isPrefixOf) +import qualified Data.Text.Lazy.IO as Text +import qualified Data.Text.Lazy as Text +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Text as Strict +import Data.Text.Format + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Language.Haskell.Meta.Parse(parseExp) + +---------------------------------------- +-- Insertion and callbacks support +---------------------------------------- +{- | +A rich apple script is a concatenation of applescript elements. See the 'applescript' quasiquoter. +-} +data AppleScript = AppleScript [AppleScriptElement] + +{- | +Plain AppleScript code, with fancy additions. +-} +data AppleScriptElement + = PlainCode !Plain.AppleScript + -- ^ Plain AppleScript code, to be inserted verbatim into the result. + | Callback !(Text -> IO Text) !Plain.AppleScript + -- ^ A callback into Haskell. Represents the @$callback{...}$[...]$@ construction. + -- An AppleScript expression @Callback f arg@ is evaluated by AppleScript roughly as follows: + -- + -- * evaluate the AppleScript code in @arg@ to produce a string @s@ + -- + -- * run @f s@ in Haskell, producing a new string @t@ + -- + -- * return the value @t@ as the result of this AppleScript expression. + -- + -- Callbacks are implemented internally by setting up a server on the Haskell side, + -- and connecting to this server from AppleScript using the unix command @nc@. The + -- main caveat of this approach is that the message produced by the AppleScript code + -- @arg@ is required to be only one line long. + | forall a. AppleScriptValue a => Value !a + -- ^ A Haskell value spliced into the applescript code. The Haskell value is serialized into + -- AppleScript code using the function 'toAppleScriptCode'. + | Nest AppleScript + -- ^ Utility for avoiding appending lists. For example: + -- + -- > f = AppleScript [ + -- > PlainCode "...", + -- > Nest someOtherAppleScriptCode, + -- > PlainCode "..." + -- > ] + +class AppleScriptValue a where + -- | Serialise the given Haskell value into AppleScript code. + toAppleScriptCode :: a -> Plain.AppleScript + +instance AppleScriptValue Int where toAppleScriptCode = Plain.AppleScript . Text.pack . show +instance AppleScriptValue Double where toAppleScriptCode = Plain.AppleScript . Text.pack . show +instance AppleScriptValue String where toAppleScriptCode = Plain.AppleScript . Text.pack . show +instance AppleScriptValue Text where toAppleScriptCode = Plain.AppleScript . Text.pack . show +instance AppleScriptValue Strict.Text where toAppleScriptCode = Plain.AppleScript . Text.pack . show + +-- | Configuration for 'runScriptFull'. Use 'def' to get a default configuration. +data AppleScriptConfig = + AppleScriptConfig { + debug :: Bool, + -- ^ If true, 'runScript' will print the generated code to stdout before + -- running it. + portGen :: IO PortNumber, + -- ^ Method for generating network ports to use for 'Callback's. + extsName :: Text + -- ^ To implement 'Callback's, 'runScript' inserts some extra AppleScript code at the + -- start of the AppleScript. This code is inserted as a script whose name is set by 'extsName'. + -- In the unlikely situation of name clashes, change 'extsName' as appropriate. + } + +{-# NOINLINE portGenCounter #-} +portGenCounter :: IORef PortNumber +portGenCounter = unsafePerformIO (newIORef 57700) + +instance Default AppleScriptConfig where + def = AppleScriptConfig { + portGen = do + port <- readIORef portGenCounter + writeIORef portGenCounter (succ port) + return port, + extsName = "__hs_exts__", + debug = False + } + +type CodeGenM = WriterT Builder.Builder (ResourceT IO) + +-- | Same as 'runScript', but sets 'debug' to 'True', so that the generated code is printed before running. +debugScript :: AppleScript -> IO () +debugScript script = ignoreResultOrThrow (runScriptFull def{debug=True} script) + +-- | Run the script using 'runScriptFull', throwing an exception on failure. +-- Ignores the script's result value. +runScript :: AppleScript -> IO () +runScript script = ignoreResultOrThrow (runScriptFull def script) + +-- | Run the script using 'runScriptFull', throwing an exception on +-- failure. Returns the script's result value, coerced to text. +-- +-- See "Foreign.AppleScript.Error" for the possible exceptions. +evalScript :: AppleScript -> IO Text +evalScript script = extractResultOrThrow (runScriptFull def script) + +-- | Run the 'AppleScript' with the given 'AppleScriptConfig'. +-- +-- Returns an exit code, together with useful text when available: +-- +-- * if the script had an error, returns the error message +-- +-- * if the script returns a value which could be coerced to text, returns this value +runScriptFull :: AppleScriptConfig -> AppleScript -> IO (ExitCode, Maybe Text) +runScriptFull conf script = runResourceT $ do + builder <- execWriterT (addSpecialFunctions >> proc script) + let code = Builder.toLazyText builder + when (debug conf) $ liftIO $ Text.putStrLn code + liftIO $ Plain.runScriptFull (Plain.AppleScript code) + where + + tell_code :: Text -> CodeGenM () + tell_code t = tell (Builder.fromLazyText t) + + matchInvalidArgument InvalidArgument = Just () + matchInvalidArgument _ = Nothing + + serverLoop handler sock = loop where + loop = do + res <- tryJust (matchInvalidArgument . ioeGetErrorType) (accept sock) + case res of + Left () -> return () -- the socket was closed, which is normal operation + Right (h,hostName,_) -> do + void $ forkIO $ + (when (hostName == "localhost") $ talk handler h) + `finally` hClose h + loop + + success_signal = "success: " + + talk :: (Text -> IO Text) -> Handle -> IO () + talk handler h = do + hSetBuffering h LineBuffering + -- AppleScript's "do shell script" uses utf8; see https://developer.apple.com/library/mac/#technotes/tn2065/_index.html + hSetEncoding h utf8 + request <- Text.hGetLine h + response <- handler request + Text.hPutStrLn h (Text.append success_signal response) + + addSpecialFunctions :: CodeGenM () + addSpecialFunctions = tell_code $ + Text.concat [ + "script ", extsName conf, "\n", + " on sendHaskellMessage(serverName, message)\n", + " if (count of (paragraphs of message)) > 1 then\n", + " error (\"callback was given more than one line of text: '\" & message & \"'\")\n", + " else\n", + " set resp to (do shell script \"echo \" & quoted form of message & \" | nc localhost \" & (quoted form of serverName))\n", + " if resp starts with ", Text.pack (show success_signal), " then\n", + " return ((characters ", Text.pack $ show $ 1 + Text.length success_signal, " thru (length of resp) of resp) as text)\n", + " else\n", + " error (\"callback didn't complete successfully. Response returned: '\" & resp & \"'\")\n", + " end if\n", + " end if\n", + " end sendHaskellMessage\n", + "end script\n" + ] + + proc :: AppleScript -> CodeGenM () + proc (AppleScript els) = mapM_ proc_el els + + proc_el :: AppleScriptElement -> CodeGenM () + proc_el (PlainCode (Plain.AppleScript t)) = tell_code t + proc_el (Callback handler arg_code) = do + -- get the port + port <- liftIO $ portGen conf + + -- start the callback server + (_, sock) <- lift $ + withIO + (listenOn (PortNumber port)) + sClose + -- (const $ return ()) + void $ lift $ withIO + (forkIO $ serverLoop handler sock) + killThread + + -- return the code + tell_code (format "({}'s sendHaskellMessage({}, {}))" (extsName conf, Shown (show port), Plain.unAppleScript arg_code)) + proc_el (Value v) = tell_code . Plain.unAppleScript . toAppleScriptCode $ v + proc_el (Nest s) = proc s + +---------------------------------------- +-- Parsing +---------------------------------------- +-- | Synonym for 'Plain.applescript' +applescriptplain :: QuasiQuoter +applescriptplain = Plain.applescript + +type Parse = StateT Text Q + +{- | +A quasiquoter for generating 'AppleScript'. This is mostly unescaped text, but with the following +special features: + + * Haskell values may be spliced directly into the code using the syntax + + > $value{ }$ + + See the 'Value' constructor for more details and types. + + * Callbacks into Haskell may be spliced using the syntax + + > $callback{ }$[ ]$ + + See the 'Callback' constructor for further details and types. + + * Extra AppleScript code may be inserted using the syntax + + > $applescript{ } + + See the 'Nest' constructor for further details and types. + +See also the example at the top of this module. +-} +applescript :: QuasiQuoter +applescript = QuasiQuoter{quoteExp=driver, quotePat=undefined, quoteType=undefined, quoteDec=undefined} + where + driver string = [| AppleScript $(evalStateT go (Text.pack string)) |] + + callbackStart = "$callback{" + valueStart = "$value{" + nestStart = "$applescript{" + starts = [callbackStart, valueStart, nestStart] + + readTo :: Text -> Parse Text + readTo needle = StateT $ \haystack -> case Text.breakOn needle haystack of + (l, Text.stripPrefix needle -> Just r) -> return (l, r) + _ -> fail $ "Missing " <> Text.unpack needle + + parseHs :: Text -> Parse ExpQ + parseHs t = case parseExp (Text.unpack t) of + Right r -> return (return r) + Left msg -> fail msg + + breakOnFirst :: [Text] -> Text -> (Text, Text) + breakOnFirst needles haystack = + minimumBy + (comparing (Text.length . fst)) + (map (\n -> Text.breakOn n haystack) needles) + + cons :: Q Exp -> Parse Exp -> Parse Exp + cons x xs = StateT $ \t -> (,t) <$> [| $x : $(evalStateT xs t) |] + + go :: Parse Exp + go = do + t <- get + case breakOnFirst starts t of + (Text.null -> True, b) -> do + put b + go' + (Text.unpack -> a, b) -> do + put b + cons [| PlainCode (Plain.AppleScript (Text.pack a)) |] go' + + -- precondition: we are looking at one of the 'starts', or else we are at eof + go' :: Parse Exp + go' = do + t <- get + if Text.null t then + lift [| [] |] + else do + script_elem <- case t of + ((callbackStart `isPrefixOf`) -> True) -> do + void $ readTo callbackStart + hask_code <- parseHs =<< readTo "}$[" + appl_code <- Text.unpack <$> readTo "]$" + return [| Callback $hask_code (Plain.AppleScript (Text.pack appl_code)) |] + ((valueStart `isPrefixOf`) -> True) -> do + void $ readTo valueStart + hask_code <- parseHs =<< readTo "}$" + return [| Value $hask_code |] + ((nestStart `isPrefixOf`) -> True) -> do + void $ readTo nestStart + hask_code <- parseHs =<< readTo "}$" + return [| Nest $hask_code |] + _ -> error "invariant violation in Foreign.AppleScript.Rich.applescript" + cons script_elem go + + diff --git a/cbits/RunScript.c b/cbits/RunScript.c --- a/cbits/RunScript.c +++ b/cbits/RunScript.c @@ -12,7 +12,34 @@ #include +size_t _hs_AEDescSize(void) { + AEDesc a; + return sizeof(a); +} +// if the input is UTF8Text, returns its size in bytes. Otherwise returns -1 +ptrdiff_t _hs_getUTF8Size(const AEDesc* input) { + if (input != NULL && input->descriptorType == typeUTF8Text) { + return AEGetDescDataSize(input); + } else { + return -1; + } +} + +OSErr _hs_getData(const AEDesc* input, void* dataPtr, size_t maxSize) { + AEGetDescData(input, dataPtr, maxSize); +} + +OSErr _hs_dispose(AEDesc* input) { + if (input != NULL && input->descriptorType != typeNull) { + AEDisposeDesc(input); + } +} + +void _hs_initNull(AEDesc * input) { + AECreateDesc(typeNull, NULL, 0, input); +} + /* AppleScriptAvailable returns true if AppleScript is available and the routines defined herein can be called. */ Boolean AppleScriptAvailable(void) { @@ -24,9 +51,10 @@ /* LowRunAppleScript compiles and runs an AppleScript provided as text in the buffer pointed to by text. textLength bytes will be compiled from this buffer and run as an AppleScript - using all of the default environment and execution settings. If - resultData is not NULL, then the result returned by the execution - command will be returned as typeChar in this descriptor record + using all of the default environment and execution settings. resultData + must be non-NULL, and should have been previously initialised, for example + with _hs_initNull. The result returned by the execution + command will be returned as typeUTF8Text in this descriptor record (or typeNull if there is no result information). If the function returns errOSAScriptError, then resultData will be set to a descriptive error message describing the error (if one is @@ -46,7 +74,7 @@ typeAppleScript); if (theComponent == NULL) { err = paramErr; goto bail; } /* put the script text into an aedesc */ - err = AECreateDesc(typeChar, text, textLength, &scriptTextDesc); + err = AECreateDesc(typeUTF8Text, text, textLength, &scriptTextDesc); if (err != noErr) goto bail; /* compile the script */ err = OSACompile(theComponent, &scriptTextDesc, @@ -56,16 +84,17 @@ err = OSAExecute(theComponent, scriptID, kOSANullScript, kOSAModeNull, &resultID); if (resultData != NULL) { - AECreateDesc(typeNull, NULL, 0, resultData); - if (err == errOSAScriptError) { - OSAScriptError(theComponent, kOSAErrorMessage, - typeChar, resultData); - } else if (err == noErr && resultID != kOSANullScript) { - OSADisplay(theComponent, resultID, typeChar, + if (err == noErr && resultID != kOSANullScript) { + OSADisplay(theComponent, resultID, typeUTF8Text, kOSAModeNull, resultData); } } bail: + if (err == errOSAScriptError) { + AECreateDesc(typeNull, NULL, 0, resultData); + OSAScriptError(theComponent, kOSAErrorMessage, typeUTF8Text, resultData); + } + AEDisposeDesc(&scriptTextDesc); if (scriptID != kOSANullScript) OSADispose(theComponent, scriptID); if (resultID != kOSANullScript) OSADispose(theComponent, resultID); diff --git a/cbits/RunScript.h b/cbits/RunScript.h --- a/cbits/RunScript.h +++ b/cbits/RunScript.h @@ -22,6 +22,12 @@ extern "C" { #endif +size_t _hs_AEDescSize(void); +ptrdiff_t _hs_getUTF8Size(const AEDesc * input); +OSErr _hs_getData(const AEDesc* input, void* dataPtr, size_t maxSize); +OSErr _hs_dispose(AEDesc* input); +void _hs_initNull(AEDesc * input); + /* AppleScriptAvailable returns true if AppleScript is available. */ Boolean AppleScriptAvailable(void); diff --git a/examples/HelloThere.hs b/examples/HelloThere.hs --- a/examples/HelloThere.hs +++ b/examples/HelloThere.hs @@ -1,19 +1,14 @@ +{-# LANGUAGE QuasiQuotes #-} import Foreign.AppleScript -- Asks for your name and says hello - -script nm = unlines $ - [ - "tell application \"Finder\"", - " delay 1", - " set volume 4", - " say \"Hello " ++ nm ++"\" using \"Vicki\"", - "end tell" - ] main = do putStrLn "What is your name?" nm <- getLine - execAppleScript (script nm) - - - + runScript [applescript| + tell application "Finder" + delay 1 + set volume 4 + say ("Hello " & $value{nm}$) using "Vicki" + end tell + |] diff --git a/examples/OpenLocation.hs b/examples/OpenLocation.hs --- a/examples/OpenLocation.hs +++ b/examples/OpenLocation.hs @@ -1,10 +1,8 @@ -import Foreign.AppleScript +{-# LANGUAGE QuasiQuotes #-} +import Foreign.AppleScript -- open a location in the default webbrowser -main = do - execAppleScript script +main = runScript [applescript| open location $value{location}$ |] location = "http://www.cs.nott.ac.uk/~wss" - -script = "open location " ++ show location diff --git a/examples/Plain.hs b/examples/Plain.hs new file mode 100644 --- /dev/null +++ b/examples/Plain.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE QuasiQuotes #-} +import Foreign.AppleScript.Plain +import qualified Data.Text.Lazy.IO as Text + +main = Text.putStrLn =<< evalScript [applescript| + tell application "System Events" + display dialog "Hello World!" + return "Viele Grüße von AppleScript!" + end tell + |] diff --git a/examples/Rich.hs b/examples/Rich.hs new file mode 100644 --- /dev/null +++ b/examples/Rich.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE QuasiQuotes #-} +import Foreign.AppleScript.Rich +import qualified Data.Text.Lazy as Text +import qualified Data.Text.Lazy.IO as Text + +main = Text.putStrLn =<< evalScript mainScript + +mainScript = [applescript| + tell application "System Events" + -- Haskell value splices, and Unicode support. + display dialog "The value of π is $value{pi :: Double}$." + + -- AppleScript can call back into Haskell. + set yourName to text returned of (display dialog "What is your name?" default answer "") + display dialog ("Your name in reverse is " & $callback{ \t -> return (Text.reverse t) }$[ yourName ]$) + + -- Splice other AppleScript code into here + $applescript{ othergreeter }$ + + -- Return text from AppleScript back to Haskell + return "Hello from AppleScript!" + end tell + |] + +othergreeter = [applescript| + display dialog "Hello from the other greeter!" + |] diff --git a/examples/RuntimeError.hs b/examples/RuntimeError.hs new file mode 100644 --- /dev/null +++ b/examples/RuntimeError.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE QuasiQuotes #-} +import Foreign.AppleScript.Plain + +main = runScript [applescript| + tell application "iTunes" + missingMessage("x") + end tell + |] diff --git a/examples/SyntaxError.hs b/examples/SyntaxError.hs new file mode 100644 --- /dev/null +++ b/examples/SyntaxError.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE QuasiQuotes #-} +import Foreign.AppleScript.Plain + +main = runScript [applescript| + tell application "iTunes" + " + end tell + |] diff --git a/examples/TextFields.hs b/examples/TextFields.hs deleted file mode 100644 --- a/examples/TextFields.hs +++ /dev/null @@ -1,14 +0,0 @@ -import Foreign.AppleScript - --- Opens a small dialog window with a text field - -main = execAppleScript dialog - -dialog = unlines $ - [ - "tell application \"System Events\"", - "display dialog \"What is your name?\" default answer \"\" buttons {\"OK\"} default button 1", - "end tell" - ] - -