This post triggered an idea:
In this example macro, I will show how I would use Hutton's Haskell parser combinator library to parse mails that match an Apple Mail rule. The macro will be triggered by a JavaScript For Automation script.
The rule could look like this:
Then, you should choose Run Applescript and pick a JavaScript For Automation script that has, for example, the following contents (remember to use the correct UUID of your macro):
function performMailActionWithMessages(messages) {
const
kme = Application("Keyboard Maestro Engine"),
subjects = JSON.stringify(
messages.map(x => x.content())
);
return (
kme.doScript("F4A275D5-C0C6-4EE0-B56F-D583B80D2E2D", {
withParameter: subjects
})
)
};
Finally, the contents of every matched message (formatted as a JSON array) are processed inside the Haskell script:
Expand disclosure triangle to see "haskell" source
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Parsing where
import Control.Applicative
import Control.Monad (replicateM, void)
import Data.Aeson
import Data.Bifunctor
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.Char
import Data.Functor
import Data.List
import Data.Map.Strict (Map, fromList, mapWithKey, restrictKeys, (!))
import Data.Set (fromList)
import Data.Text (justifyRight, pack, unpack)
import Data.Text.Encoding (decodeUtf8)
between open close p = open >> p >>= \v -> close >> pure v
-- Based on functional parsing library from chapter 13
-- of Programming in Haskell,
-- Graham Hutton, Cambridge University Press, 2016.
newtype Parser a
= P (String -> [(a, String)])
parse :: Parser a -> String -> [(a, String)]
parse (P p) = p
item :: Parser Char
item =
P
( \case
[] -> []
(x : xs) -> [(x, xs)]
)
instance Functor Parser where
-- fmap :: (a -> b) -> Parser a -> Parser b
fmap f p =
P
( \inp ->
case parse p inp of
[] -> []
[(v, out)] -> [(f v, out)]
)
instance Applicative Parser where
-- pure :: a -> Parser a
pure v = P (\inp -> [(v, inp)])
-- <*> :: Parser (a -> b) -> Parser a -> Parser b
(<*>) pg px =
P
( \inp ->
case parse pg inp of
[] -> []
[(g, out)] -> parse (fmap g px) out
)
instance Monad Parser where
-- (>>=) :: Parser a -> (a -> Parser b) -> Parser b
p >>= f =
P
( \inp ->
case parse p inp of
[] -> []
[(v, out)] -> parse (f v) out
)
-- Making choices
instance Alternative Parser where
-- empty :: Parser a
empty = P (const [])
-- (<|>) :: Parser a -> Parser a -> Parser a
p <|> q =
P
( \inp ->
case parse p inp of
[] -> parse q inp
[(v, out)] -> [(v, out)]
)
-- Derived primitives
-- sepBy1 p sep = liftM2 (:) p (many (sep >> p))
sepBy1 :: (Alternative f, Monad f) => f a1 -> f a2 -> f [a1]
sepBy1 p sep = (:) <$> p <*> many (sep >> p)
sepBy2 p = (:) <$> p <*> many p
commaSep p = sepBy1 p (string ",")
tagSep p = sepBy1 p (string " @")
count :: Int -> Parser a -> Parser [a]
count = replicateM
satisfy :: (Char -> Bool) -> Parser Char
satisfy p = item >>= go
where
go x
| p x = pure x
| otherwise = empty
digit :: Parser Char
digit = satisfy isDigit
digits :: Parser [Char]
digits = some digit
lower :: Parser Char
lower = satisfy isLower
upper :: Parser Char
upper = satisfy isUpper
letter :: Parser Char
letter = satisfy isAlpha
alphanum :: Parser Char
alphanum = satisfy isAlphaNum
char :: Char -> Parser Char
char x = satisfy (== x)
noneOf :: String -> Parser Char
noneOf cs = satisfy (`notElem` cs)
oneOf :: String -> Parser Char
oneOf cs = satisfy (`elem` cs)
string :: String -> Parser String
string [] = pure []
string (x : xs) = char x >> string xs >> pure (x : xs)
ident :: Parser String
ident = lower >>= \x -> many alphanum >>= \xs -> pure (x : xs)
constructor :: Parser String
constructor = upper >>= \x -> many alphanum >>= \xs -> pure (x : xs)
subscriptedIdentifier :: Parser String
subscriptedIdentifier = lower >>= \x -> many (alphanum <|> char '_' <|> char '\'') >>= \xs -> pure (x : xs)
operator :: Parser String
operator = some (oneOf "/=-+!*%<>&|^?•$")
nat :: Parser Int
nat = read <$> some digit
int :: Parser Int
int = (char '-' >> nat >>= \n -> pure (-n)) <|> nat
-- Handling spacing
space :: Parser ()
space = void $ many (satisfy isSpace)
quoted :: Parser [Char]
quoted = (oneOf "'\"") >>= \x -> (many (noneOf "'\"")) >>= \xs -> (oneOf "'\"") >>= \y -> pure (x : xs <> [y])
singleQuoted :: Parser [Char]
singleQuoted = between (char '\'') (char '\'') (many (satisfy ('\'' /=))) >>= \xs -> pure ("'" <> xs <> "'")
doubleQuoted :: Parser [Char]
doubleQuoted = between (char '"') (char '"') (many (satisfy ('"' /=))) >>= \xs -> pure ("'" <> xs <> "'")
digitString :: Parser String
digitString = many (satisfy isDigit)
naturalNumber :: Parser Int
naturalNumber = read <$> digitString
token :: Parser a -> Parser a
token p = space >> p >>= \v -> space >> pure v
token1 :: Parser a -> Parser a
token1 p = many (oneOf " ()[]{},:`") >> p >>= \v -> many (oneOf " ()[]{},:") >> pure v
identifier :: Parser String
identifier = token ident
method :: Parser String
method = char '.' >>= \x -> many alphanum >>= \xs -> pure (x : xs)
natural :: Parser Int
natural = token nat
integer :: Parser Int
integer = token int
symbol :: String -> Parser String
symbol xs = token (string xs)
interact' :: (String -> String) -> IO ()
interact' f = do
path <- getContents
s <- readFile path
putStr (f s)
termPrompts :: String -> [[Char]]
termPrompts s = map (dropWhile (/= '[')) $ filter (isInfixOf "has been terminated") (lines s)
-- parsers
pEmpID :: Parser Int
pEmpID = (read :: String -> Int) <$> between (char '[') (char ']') (many (satisfy (']' /=)))
pEntity :: Parser [Char]
pEntity = token (string "has been terminated for") >> many upper
pTermDate :: Parser [Char]
pTermDate = token (string "on") >> many (satisfy (not . isSpace))
pMailInfo :: Parser MailInfo
pMailInfo = MailInfo <$> pEmpID <*> pEntity <*> pTermDate
-- MailInfo datatype
data MailInfo = MailInfo
{ empID :: Int,
entity :: String,
termDate :: String
}
deriving (Show)
instance ToJSON MailInfo where
toJSON (MailInfo empID entity termDate) =
object ["empID" .= empID, "entity" .= entity, "termDate" .= termDate]
jsonStr :: String
jsonStr = "[\"Some\\nJohn Smith [152637] has been terminated for XYZ on 02/07/2023\\nPlease update the necessary fields\"]"
str = "Some\nJohn Smith [152637] has been terminated for XYZ on 02/07/2023\nPlease update the necessary fields"
interact'' :: ([String] -> IO ()) -> IO ()
interact'' f =
LB.getContents
>>= LB.readFile . unpack . decodeUtf8 . LB.toStrict
>>= pure . (eitherDecode :: LB.ByteString -> Either String ([String]))
>>= either putStrLn f
mailInfo :: String -> [MailInfo]
mailInfo = concatMap (map fst . parse pMailInfo) . termPrompts
-- main :: IO ()
-- main = print $ (eitherDecode :: LB.ByteString -> Either String ([String])) "[\"Some\\nJohn Smith [152637] has been terminated for XYZ on 02/07/2023\\nPlease update the necessary fields\"]"
main :: IO ()
main =
interact'' $
( LB.putStr
. encode
. concatMap mailInfo
)
Download Macro(s): Parse incoming mail triggered by rule.kmmacros (14 KB)
Macro-Notes
- Macros are always disabled when imported into the Keyboard Maestro Editor.
- The user must ensure the macro is enabled.
- The user must also ensure the macro's parent macro-group is enabled.
- The macro requires the following Plug-In: Execute a Haskell Script with Arguments - #3 by unlocked2412
System Information
- macOS 13.1
- Keyboard Maestro v10.2