AppleScript 0.1.5 → 0.2
raw patch · 14 files changed
+707/−91 lines, 14 filesdep +bytestringdep +conduitdep +data-defaultnew-uploader
Dependencies added: bytestring, conduit, data-default, directory, haskell-src-meta, mtl, network, template-haskell, text, text-format
Files
- AppleScript.cabal +35/−10
- Foreign/AppleScript.hs +3/−39
- Foreign/AppleScript/Error.hs +51/−0
- Foreign/AppleScript/Plain.hs +127/−0
- Foreign/AppleScript/Rich.hs +382/−0
- cbits/RunScript.c +39/−10
- cbits/RunScript.h +6/−0
- examples/HelloThere.hs +8/−13
- examples/OpenLocation.hs +3/−5
- examples/Plain.hs +10/−0
- examples/Rich.hs +27/−0
- examples/RuntimeError.hs +8/−0
- examples/SyntaxError.hs +8/−0
- examples/TextFields.hs +0/−14
AppleScript.cabal view
@@ -1,25 +1,50 @@ Name: AppleScript-Version: 0.1.5+Version: 0.2 License: BSD3 License-file: LICENSE-Author: Wouter Swierstra-Maintainer: Wouter Swierstra <wouter@chalmers.se>-Synopsis: Call AppleScript from Haskell.-Description: This package enables you to compile and - execute AppleScript from Haskell applications.+Author: Wouter Swierstra <wouter.swierstra@gmail.com>, Reiner Pope <reiner.pope@gmail.com>+Maintainer: Reiner Pope <reiner.pope@gmail.com>+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
Foreign/AppleScript.hs view
@@ -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
+ Foreign/AppleScript/Error.hs view
@@ -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
+ Foreign/AppleScript/Plain.hs view
@@ -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) |]
+ Foreign/AppleScript/Rich.hs view
@@ -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{ <haskell code> }$++ See the 'Value' constructor for more details and types.++ * Callbacks into Haskell may be spliced using the syntax ++ > $callback{ <haskell code> }$[ <applescript code> ]$++ See the 'Callback' constructor for further details and types.++ * Extra AppleScript code may be inserted using the syntax++ > $applescript{ <haskell code> }++ 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++
cbits/RunScript.c view
@@ -12,7 +12,34 @@ #include <string.h> +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);
cbits/RunScript.h view
@@ -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);
examples/HelloThere.hs view
@@ -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+ |]
examples/OpenLocation.hs view
@@ -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
+ examples/Plain.hs view
@@ -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+ |]
+ examples/Rich.hs view
@@ -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!"+ |]
+ examples/RuntimeError.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE QuasiQuotes #-}+import Foreign.AppleScript.Plain++main = runScript [applescript|+ tell application "iTunes"+ missingMessage("x")+ end tell+ |]
+ examples/SyntaxError.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE QuasiQuotes #-}+import Foreign.AppleScript.Plain++main = runScript [applescript|+ tell application "iTunes"+ "+ end tell+ |]
− examples/TextFields.hs
@@ -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"- ] --