From f98f45714264f3b58ebf9f0b5765536e05c68162 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Mon, 14 Sep 2015 10:24:49 +0200 Subject: [PATCH 1/4] Stack-ized the project, made it build with latest packages --- AppleScript.cabal | 23 ++++++++++++----------- Foreign/AppleScript/Rich.hs | 33 ++++++++++++++++----------------- stack.yaml | 5 +++++ 3 files changed, 33 insertions(+), 28 deletions(-) create mode 100644 stack.yaml diff --git a/AppleScript.cabal b/AppleScript.cabal index 3b60718..e56cac8 100644 --- a/AppleScript.cabal +++ b/AppleScript.cabal @@ -1,5 +1,5 @@ Name: AppleScript -Version: 0.2.0.1 +Version: 0.2.0.2 License: BSD3 License-file: LICENSE Author: Wouter Swierstra , Reiner Pope @@ -30,16 +30,17 @@ Library { if os(darwin) { Buildable: True 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.* + bytestring, + data-default, + text, + haskell-src-meta >= 0.5.0.3, + text-format, + network, + conduit, + resourcet, + directory, + template-haskell >= 2.7.0.0, + mtl Exposed-modules: Foreign.AppleScript Foreign.AppleScript.Error diff --git a/Foreign/AppleScript/Rich.hs b/Foreign/AppleScript/Rich.hs index 3a59778..a9d7257 100644 --- a/Foreign/AppleScript/Rich.hs +++ b/Foreign/AppleScript/Rich.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE - TemplateHaskell, - OverloadedStrings, - ExistentialQuantification, - ViewPatterns, - TupleSections, - TypeSynonymInstances, - FlexibleInstances +{-# LANGUAGE + TemplateHaskell, + OverloadedStrings, + ExistentialQuantification, + ViewPatterns, + TupleSections, + TypeSynonymInstances, + FlexibleInstances #-} {-# OPTIONS_GHC -funbox-strict-fields -Wall -Werror #-} @@ -27,14 +27,14 @@ -- > 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 @@ -52,6 +52,7 @@ module Foreign.AppleScript.Rich -- * Common-use functions Plain.appleScriptAvailable, applescript, + applescriptplain, runScript, evalScript, debugScript, @@ -63,16 +64,15 @@ module Foreign.AppleScript.Rich -- * 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.Monad.Trans.Resource(ResourceT, runResourceT, allocate) import Control.Exception(tryJust, finally) import Control.Concurrent(forkIO, killThread) @@ -275,12 +275,11 @@ runScriptFull conf script = runResourceT $ do port <- liftIO $ portGen conf -- start the callback server - (_, sock) <- lift $ - withIO + (_, sock) <- lift $ allocate (listenOn (PortNumber port)) sClose -- (const $ return ()) - void $ lift $ withIO + void $ lift $ allocate (forkIO $ serverLoop handler sock) killThread diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..8130c99 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,5 @@ +flags: {} +packages: +- '.' +extra-deps: [] +resolver: lts-3.0 From 8919a8a4b02ae9f7b4861a42a050c8c5fdd60ed2 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Mon, 14 Sep 2015 10:25:27 +0200 Subject: [PATCH 2/4] Gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8ee1bf9 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +.stack-work From bedcf09a0230c20d6a846a3601501578acccadff Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Wed, 31 May 2023 20:34:39 +0100 Subject: [PATCH 3/4] Fix network code to compile in GHC 9.* --- Foreign/AppleScript/Rich.hs | 32 +++++++++++++++++++++----------- 1 file changed, 21 insertions(+), 11 deletions(-) diff --git a/Foreign/AppleScript/Rich.hs b/Foreign/AppleScript/Rich.hs index a9d7257..29fe9a7 100644 --- a/Foreign/AppleScript/Rich.hs +++ b/Foreign/AppleScript/Rich.hs @@ -70,8 +70,9 @@ module Foreign.AppleScript.Rich import Foreign.AppleScript.Error import qualified Foreign.AppleScript.Plain as Plain +import Control.Monad import Control.Monad.State -import Control.Monad.Writer +import Control.Monad.Writer hiding (listen) import Control.Monad.Trans.Resource(ResourceT, runResourceT, allocate) import Control.Exception(tryJust, finally) @@ -84,7 +85,7 @@ import GHC.IO.Exception(IOErrorType(InvalidArgument)) import System.Exit -import Network(accept, listenOn, sClose, PortID(..), PortNumber) +import Network.Socket import Data.List(minimumBy) import Data.Ord(comparing) @@ -229,16 +230,18 @@ runScriptFull conf script = runResourceT $ 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 + Right (sock',peerAddr) -> do + void $ forkIO $ do + myAddr <- getSocketName sock' + (when (myAddr == peerAddr) $ talk handler sock') + `finally` close sock loop success_signal = "success: " - talk :: (Text -> IO Text) -> Handle -> IO () - talk handler h = do + talk :: (Text -> IO Text) -> Socket -> IO () + talk handler sock = do + h <- socketToHandle sock ReadWriteMode hSetBuffering h LineBuffering -- AppleScript's "do shell script" uses utf8; see https://developer.apple.com/library/mac/#technotes/tn2065/_index.html hSetEncoding h utf8 @@ -273,12 +276,19 @@ runScriptFull conf script = runResourceT $ do proc_el (Callback handler arg_code) = do -- get the port port <- liftIO $ portGen conf + -- get addr including port + addr:_ <- liftIO $ getAddrInfo (Just defaultHints) Nothing (Just (show port)) -- start the callback server (_, sock) <- lift $ allocate - (listenOn (PortNumber port)) - sClose - -- (const $ return ()) + (do + sock <- openSocket addr + bind sock (addrAddress addr) + listen sock 1 + return sock + ) + close + void $ lift $ allocate (forkIO $ serverLoop handler sock) killThread From 9b05325b2ab4bd85e1a8346e5eef0dc11b3bb9f3 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Wed, 31 May 2023 23:12:31 +0100 Subject: [PATCH 4/4] Better AppleScriptValue instances Previously we were using "show" in instances for String, Text, and Strict.Text. However, this causes failures in most values spliced in between quotes. Therefore, we no longer "show" the textual values and instead simply use them as is. If quotes around the string are desired it must be shown manually or added manually. --- Foreign/AppleScript/Rich.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Foreign/AppleScript/Rich.hs b/Foreign/AppleScript/Rich.hs index 29fe9a7..06b7209 100644 --- a/Foreign/AppleScript/Rich.hs +++ b/Foreign/AppleScript/Rich.hs @@ -154,9 +154,9 @@ class AppleScriptValue a where 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 +instance AppleScriptValue String where toAppleScriptCode = Plain.AppleScript . Text.pack +instance AppleScriptValue Text where toAppleScriptCode = Plain.AppleScript +instance AppleScriptValue Strict.Text where toAppleScriptCode = Plain.AppleScript . Text.fromStrict -- | Configuration for 'runScriptFull'. Use 'def' to get a default configuration. data AppleScriptConfig =