module Workflow.Pure.Execute where
import Workflow.Types
import Control.Monad.Free
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer
import Control.Monad.Trans.Maybe
import Data.Foldable (traverse_)
import Data.List (intercalate)
import Data.Monoid ((<>))
import Data.Function ((&))
isSimpleWorkflow :: Workflow x -> Maybe [Workflow_]
isSimpleWorkflow m = (runIdentity . runMaybeT . execWriterT) (goM m)
where
log = tell . (:[])
goM :: Workflow x -> SimpleWorkflowM ()
goM = \case
Pure _ -> return ()
Free a -> goF a
goF :: WorkflowF (Workflow x) -> SimpleWorkflowM ()
goF = \case
SendKeyChord flags key k -> log (SendKeyChord_ flags key) >> goM k
SendText s k -> log (SendText_ s ) >> goM k
SendMouseClick flags n button k -> log (SendMouseClick_ flags n button) >> goM k
SendMouseScroll flags scroll n k -> log (SendMouseScroll_ flags scroll n) >> goM k
SetClipboard s k -> log (SetClipboard_ s ) >> goM k
OpenApplication app k -> log (OpenApplication_ app) >> goM k
OpenURL url k -> log (OpenURL_ url) >> goM k
Delay t k -> log (Delay_ t ) >> goM k
GetClipboard _ -> mzero
CurrentApplication _ -> mzero
type SimpleWorkflowM = WriterT [Workflow_] (MaybeT Identity)
showWorkflow :: (Show x) => Workflow x -> String
showWorkflow m = "do\n" <> (evalState&flip) 1 (showWorkflow_ m)
where
showWorkflow_ :: (Show x) => Workflow x -> GensymM String
showWorkflow_ = \case
Pure x -> return $ " return " <> show x <> "\n"
Free a -> showWorkflowF a
showWorkflowF :: (Show x) => WorkflowF (Workflow x) -> GensymM String
showWorkflowF = \case
SendKeyChord flags key k ->
((" sendKeyChord " <> showArgs [show flags, show key]) <>) <$> showWorkflow_ k
SendText s k ->
((" sendText " <> showArgs [show s]) <>) <$> showWorkflow_ k
SendMouseClick flags n button k ->
((" sendMouseClick " <> showArgs [show flags, show n, show button]) <>) <$> showWorkflow_ k
SendMouseScroll flags scroll n k ->
((" sendMouseScroll " <> showArgs [show flags, show scroll, show n]) <>) <$> showWorkflow_ k
SetClipboard s k ->
((" setClipboard " <> showArgs [show s]) <>) <$> showWorkflow_ k
OpenApplication app k ->
((" openApplication " <> showArgs [show app]) <>) <$> showWorkflow_ k
OpenURL url k ->
((" openURL " <> showArgs [show url]) <>) <$> showWorkflow_ k
Delay t k ->
((" delay " <> showArgs [show t]) <>) <$> showWorkflow_ k
GetClipboard f -> do
x <- gensym
rest <- showWorkflow_ (f ("{"<>x<>"}"))
return $ " " <> x <> " <- getClipboard" <> showArgs [] <> rest
CurrentApplication f -> do
x <- gensym
rest <- showWorkflow_ (f ("{"<>x<>"}"))
return $ " " <> x <> " <- currentApplication" <> showArgs [] <> rest
showArgs :: [String] -> String
showArgs xs = intercalate " " (fmap (("(" <>) . (<> ")")) xs) <> "\n"
gensym :: State Int String
gensym = do
i <- get
put $ i + 1
return $ "x" <> show i
type GensymM = State Gensym
type Gensym = Int