workflow-types (empty) → 0.0.0

raw patch · 12 files changed

+1538/−0 lines, 12 filesdep +Earleydep +basedep +comonadsetup-changed

Dependencies added: Earley, base, comonad, containers, deepseq, exceptions, free, hashable, semigroups, split, transformers, workflow-types

Files

LICENSE +22/−0
Setup.hs +3/−0
executables/Main.hs +4/−0
sources/Workflow/Core.hs +31/−0
sources/Workflow/Example.hs +12/−0
sources/Workflow/Execute.hs +126/−0
sources/Workflow/Extra.hs +26/−0
sources/Workflow/Keys.hs +486/−0
sources/Workflow/Parser.hs +146/−0
sources/Workflow/Reexports.hs +7/−0
sources/Workflow/Types.hs +606/−0
workflow-types.cabal +69/−0

+ LICENSE view

@@ -0,0 +1,22 @@+The MIT License (MIT)
+
+Copyright (c) 2015 Sam Boosalis
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+

+ Setup.hs view

@@ -0,0 +1,3 @@+import Distribution.Simple
+main = defaultMain
+

+ executables/Main.hs view

@@ -0,0 +1,4 @@+import qualified Workflow.Example
+
+main = do
+  Workflow.Example.main

+ sources/Workflow/Core.hs view

@@ -0,0 +1,31 @@+{-| Automate keyboard\/mouse\/clipboard\/application interaction.
+
+the core types that define platform-diagnostic workflows,
+as well as helpers for parsing keychords and implementing backends.
+
+(see 'WorkflowF', 'MonadWorkflow', 'Key', 'press', 'WorkflowD')
+
+-}
+module Workflow.Core
+ ( module Workflow.Types
+ , module Workflow.Execute
+ , module Workflow.Keys
+ , module Workflow.Reexports
+ )
+ where
+import Workflow.Types
+import Workflow.Execute
+import Workflow.Keys
+import Workflow.Reexports
+
+{-TODO (Doesn't work)
+
+Re-exports "Control.Monad.Catch", instances only.
+By re-exporting these instances ourselves (e.g. @instance MonadThrow IO@),
+we save clients from explicitly depending on the @exceptions@ package
+in their @build-depends@.
+
+ , module Control.Monad.Catch
+import qualified Control.Monad.Catch ()
+
+-}

+ sources/Workflow/Example.hs view

@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+module Workflow.Example where
+import Workflow.Core
+import qualified Workflow.Parser
+
+{-
+stack build && stack exec -- workflow-types-example
+-}
+
+main = do
+  print $ readEmacsKeySequence "H-S-t H-l"  -- "re-open tab", then "jump to url bar"
+

+ sources/Workflow/Execute.hs view

@@ -0,0 +1,126 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, RecordWildCards #-}
+{-# LANGUAGE RankNTypes #-}
+module Workflow.Execute where
+import Workflow.Types
+
+import Control.Monad.Trans.Free (iterT)
+
+import Control.Monad.IO.Class
+import Control.Concurrent (threadDelay)
+import Numeric.Natural
+
+
+{-| An explicit "typeclass dictionary" for interpreting a 'MonadWorkflow'.
+
+i.e. a generic handler/interpreter (product type)
+for 'WorkflowF' effects (a sum type).
+
+e.g.
+
+@
+WorkflowD IO
+@
+
+template:
+
+@
+myDictionary :: (MonadIO m) => WorkflowD m
+myDictionary = WorkflowD{..}
+ where
+  _sendKeyChord =
+  _sendText     =
+
+  _sendMouseClick  =
+  _sendMouseScroll =
+
+  _getClipboard =
+  _setClipboard =
+
+  _currentApplication =
+  _openApplication    =
+  _openURL            =
+
+runWorkflowByMy :: (MonadIO m) => WorkflowT m a -> m a
+runWorkflowByMy = runWorkflowByT myDictionary
+@
+
+'Delay' is elided, as its implementation can use
+cross-platform 'IO' ('threadDelay').
+
+see 'runWorkflowByT'
+
+-}
+data WorkflowD m = WorkflowD
+ { _sendKeyChord       :: [Modifier] -> Key -> m ()
+ , _sendText           :: String            -> m ()
+
+ , _sendMouseClick     :: [Modifier] -> Natural     -> MouseButton -> m ()
+ , _sendMouseScroll    :: [Modifier] -> MouseScroll -> Natural     -> m ()
+
+ , _getClipboard       :: m Clipboard
+ , _setClipboard       :: (Clipboard -> m ())
+
+ , _currentApplication :: m Application
+ , _openApplication    :: Application -> m ()
+
+ , _openURL            :: URL -> m ()
+
+ -- , _delay :: MilliSeconds -> m ()
+ } -- deriving (Functor)
+
+--------------------------------------------------------------------------------
+
+{-|
+
+e.g.
+
+@
+shellDictionary :: WorkflowD IO
+shellDictionary = WorkflowD{..}
+ where
+ '_getClipboard' = shell $ "pbpaste"
+ '_setClipboard' s = shell $ "echo "++(shellEscape s)++"| pbcopy" >> return ()
+ ...
+
+runWorkflowByShell :: (MonadIO m) => 'WorkflowT' m a -> m a
+runWorkflowByShell = runWorkflowByT shellDictionary
+
+-- specializeable:
+-- runWorkflowByShell :: 'Workflow' a -> IO a
+@
+
+-}
+runWorkflowByT
+  :: forall m a. (MonadIO m)
+  -- => CoWorkflowT (m a)
+  => WorkflowD m
+  -> WorkflowT m a
+  -> m a
+-- runWorkflowByT CoWorkflowF{..} = iterT go
+runWorkflowByT WorkflowD{..} = iterT go
+ where
+
+ go :: WorkflowF (m a) -> m a
+ go = \case
+
+  SendKeyChord    flags key k      -> _sendKeyChord flags key >> k
+  SendText        s k              -> _sendText s             >> k
+
+  SendMouseClick  flags n button k    -> _sendMouseClick flags n button     >> k
+  SendMouseScroll flags scrolling n k -> _sendMouseScroll flags scrolling n >> k
+
+  GetClipboard    f                -> _getClipboard   >>= f
+  SetClipboard    s k              -> _setClipboard s >>  k
+
+  CurrentApplication f             -> _currentApplication  >>= f
+  OpenApplication app k            -> _openApplication app >>  k
+  OpenURL         url k            -> _openURL url         >>  k
+
+  Delay           t k              -> delayMilliseconds t >> k
+ -- 1,000 µs is 1ms
+
+delayMilliseconds :: (MonadIO m) => Int -> m ()
+delayMilliseconds = liftIO . threadDelay . (*1000)
+
+delaySeconds :: (MonadIO m) => Int -> m ()
+delaySeconds =  delayMilliseconds . (*1000)

+ sources/Workflow/Extra.hs view

@@ -0,0 +1,26 @@+module Workflow.Extra
+ ( module Workflow.Extra
+ , module X
+ ) where
+
+import Control.DeepSeq as X (NFData)
+import Data.Hashable as X (Hashable)
+import Data.Semigroup as X (Semigroup)
+import Control.Monad.Catch as X (MonadThrow(..))
+
+import Data.Data as X (Data)
+import GHC.Generics as X (Generic)
+import Control.Arrow as X ((>>>))
+import Control.Monad as X ((>=>))
+import Data.Function as X ((&),on)
+import Data.Foldable as X (traverse_)
+
+import Control.Exception (ErrorCall(..))
+
+(-:) :: a -> b -> (a,b)
+(-:) = (,)
+infix 1 -:
+
+failed :: (MonadThrow m) => String -> m a
+failed = ErrorCall >>> throwM
+

+ sources/Workflow/Keys.hs view

@@ -0,0 +1,486 @@+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
+module Workflow.Keys where --TODO mv to workflow-derived
+import Workflow.Types
+import Workflow.Extra
+
+import Data.List.Split
+
+import qualified Data.Map.Strict as Map
+import           Data.Map.Strict (Map)
+
+--------------------------------------------------------------------------------
+
+{-| Parses and executes a keyboard shortcut. (via 'readKeySequence' and 'sendKeyChord').
+
+* more convenient than manually constructing 'Modifier's and 'Key's.
+* but, (safely) partial
+
+e.g. compare:
+
+@
+press "H-S-t H-l"
+@
+
+to:
+
+@
+'traverse_' 'sendKeyChord''
+ [ 'KeyChord' ['HyperModifier', 'ShiftModifier'] 'TKey'
+ , 'KeyChord' ['HyperModifier') 'LKey'
+ ]
+@
+
+(a keyboard shortcut to "re-open tab, then jump to url bar")
+
+'throwM's on a "syntax error"
+
+The default syntax is inspired by Emacs:
+
+@
+press = 'press'' 'defaultKeyChordSyntax'
+@
+
+-}
+press :: (MonadWorkflow m, MonadThrow m) => String -> m ()
+press = press' defaultKeyChordSyntax
+
+{-|
+
+>>> readEmacsKeySequence "H-S-t H-l"
+Just [([HyperModifier,ShiftModifier],TKey),([HyperModifier],LKey)]
+
+@='readEmacsKeySequence' 'emacsKeyChordSyntax'@
+
+-}
+readEmacsKeySequence :: String -> Maybe KeySequence
+readEmacsKeySequence = readKeySequence emacsKeyChordSyntax
+
+{-|
+
+>>> readEmacsKeyChord "H-S-t"
+Just ([HyperModifier,ShiftModifier],TKey)
+
+@='readEmacsKeyChord' 'emacsKeyChordSyntax'@
+
+-}
+readEmacsKeyChord :: String -> Maybe KeySequence
+readEmacsKeyChord = readKeySequence emacsKeyChordSyntax
+
+{- |
+
+>>> readEmacsModifier "H"
+Just HyperModifier
+
+@='readModifier' 'emacsModifierSyntax'@
+
+-}
+readEmacsModifier :: String -> Maybe Modifier
+readEmacsModifier = readModifier emacsModifierSyntax
+
+{- |
+
+>>> readEmacsKey "<tab>"
+Just TabKey
+
+@='readKey' 'emacsKeySyntax'@
+
+-}
+readEmacsKey :: String -> Maybe KeyChord
+readEmacsKey = readKey emacsKeySyntax
+
+--------------------------------------------------------------------------------
+
+{-| Build your own 'press'. e.g.
+
+@
+import "Workflow.Core" hiding (press)
+
+press = press' KeyChordSyntax{..}
+
+modifierSyntax :: ModifierSyntax
+modifierSyntax = defaultModifierSyntax -- defaulting
+
+keySyntax :: KeySyntax     -- overriding
+keySyntax = Map.fromList
+ [ ...
+ ]
+
+@
+-}
+press' :: (MonadWorkflow m, MonadThrow m) => KeyChordSyntax -> String -> m ()
+press' syntax s = go s
+
+  where
+  go = (readKeySequence syntax >>> __cast__) >=> traverse_ sendKeyChord'
+  __cast__ = \case
+    Nothing -> __fail__
+    Just [] -> __fail__ --TODO? readKeySequence :: MonadThrow m => String -> m KeySequence
+    Just ks -> return ks --TODO NonEmpty
+
+  __fail__ = failed $ "syntax error: {{Workflow.Keys.press "++(show s)++"}}"
+    -- TODO? Control.Monad.Fail (MonadFail(..))
+
+readKeySequence :: KeyChordSyntax -> String -> Maybe KeySequence --TODO Either ReadKeySequenceError / ErrorReadingKeySequence
+readKeySequence syntax --TODO plural? --TODO make extensible with Map Char Key and Map String Modifier and inner-div and outer-div
+ = splitOn " " >>> fmap (splitOn "-") >>> traverse (readKeyChord syntax)
+ -- >>> fmap concat
+
+readKeyChord :: KeyChordSyntax -> [String] -> Maybe KeyChord
+readKeyChord KeyChordSyntax{..} = \case
+ []      -> Nothing
+ s@(_:_) -> do
+   ms <- traverse (readModifier modifierSyntax) (init s) --NOTE total, TODO prove with NonEmpty.init
+   k  <-          (readKey      keySyntax)      (last s) --NOTE total --TODO munch uppercase until lwoer
+   return $ addMods ms k
+
+-- | surjective, non-injective.
+readModifier :: ModifierSyntax -> String -> Maybe Modifier
+readModifier = (flip Map.lookup)
+
+-- |
+readKey :: KeySyntax -> String -> Maybe KeyChord --TODO string for non-alphanums like <spc>
+readKey = (flip Map.lookup)
+
+--------------------------------------------------------------------------------
+
+{-| A table for parsing strings of modifiers and keys.
+
+-}
+data KeyChordSyntax = KeyChordSyntax
+ { modifierSyntax :: ModifierSyntax
+ , keySyntax      :: KeySyntax
+ }  deriving (Show,Read,Eq,Ord,Data,Generic)
+instance NFData KeyChordSyntax
+
+-- | '<>' overrides (i.e. right-biased i.e. pick the last).
+instance Monoid KeyChordSyntax where
+  mempty = KeyChordSyntax mempty mempty
+  mappend (KeyChordSyntax m1 k1) (KeyChordSyntax m2 k2) = KeyChordSyntax{..}
+   where
+   modifierSyntax = Map.unionWith (curry snd) m1 m2
+   keySyntax      = Map.unionWith (curry snd) k1 k2
+
+type ModifierSyntax = Map String Modifier
+
+type KeySyntax = Map String KeyChord
+
+-- | @= 'emacsKeyChordSyntax'@
+defaultKeyChordSyntax :: KeyChordSyntax
+defaultKeyChordSyntax = KeyChordSyntax defaultModifierSyntax defaultKeySyntax
+
+-- | @= 'emacsModifierSyntax'@
+defaultModifierSyntax :: ModifierSyntax
+defaultModifierSyntax = emacsModifierSyntax
+
+-- | @= 'emacsKeySyntax'@
+defaultKeySyntax :: KeySyntax
+defaultKeySyntax = emacsKeySyntax
+
+-- | @= 'KeyChordSyntax' 'defaultModifierSyntax' 'defaultKeySyntax'@
+emacsKeyChordSyntax :: KeyChordSyntax
+emacsKeyChordSyntax = KeyChordSyntax defaultModifierSyntax defaultKeySyntax
+
+-- | (see source)
+emacsModifierSyntax :: ModifierSyntax
+emacsModifierSyntax = Map.fromList
+  [ "M" -: MetaModifier
+  , "H" -: HyperModifier --TODO C
+  , "C" -: ControlModifier --TODO N / R / L
+  , "O" -: OptionModifier --TODO A
+  , "A" -: OptionModifier
+  , "S" -: ShiftModifier
+  , "F" -: FunctionModifier
+  ]
+
+{- |
+
+follows <http://emacswiki.org/emacs/EmacsKeyNotation Emacs keybinding syntax>, with some differences:
+
+* non-modifier uppercase alphabetic characters are not shifted, for consistency:
+
+      * e.g. use @"M-S-a"@, not @"M-A"@
+      * e.g. but @"M-:"@ and @"M-S-;"@ can both be used
+
+* non-alphanumeric characters can be in angle brackets:
+
+      * e.g. use @"C-<tab>"@, not @"C-TAB"@
+      * e.g. but @"C-\t"@ can be used
+
+(see source)
+
+-}
+emacsKeySyntax :: KeySyntax --TODO newtype, def, IsList --TODO modules, neither explicit nor implicit param
+emacsKeySyntax = Map.fromList
+  [ "a"  -: KeyChord [             ] AKey
+  , "A"  -: KeyChord [ShiftModifier] AKey
+  , "b"  -: KeyChord [             ] BKey
+  , "B"  -: KeyChord [ShiftModifier] BKey
+  , "c"  -: KeyChord [             ] CKey
+  , "C"  -: KeyChord [ShiftModifier] CKey
+  , "d"  -: KeyChord [             ] DKey
+  , "D"  -: KeyChord [ShiftModifier] DKey
+  , "e"  -: KeyChord [             ] EKey
+  , "E"  -: KeyChord [ShiftModifier] EKey
+  , "f"  -: KeyChord [             ] FKey
+  , "F"  -: KeyChord [ShiftModifier] FKey
+  , "g"  -: KeyChord [             ] GKey
+  , "G"  -: KeyChord [ShiftModifier] GKey
+  , "h"  -: KeyChord [             ] HKey
+  , "H"  -: KeyChord [ShiftModifier] HKey
+  , "i"  -: KeyChord [             ] IKey
+  , "I"  -: KeyChord [ShiftModifier] IKey
+  , "j"  -: KeyChord [             ] JKey
+  , "J"  -: KeyChord [ShiftModifier] JKey
+  , "k"  -: KeyChord [             ] KKey
+  , "K"  -: KeyChord [ShiftModifier] KKey
+  , "l"  -: KeyChord [             ] LKey
+  , "L"  -: KeyChord [ShiftModifier] LKey
+  , "m"  -: KeyChord [             ] MKey
+  , "M"  -: KeyChord [ShiftModifier] MKey
+  , "n"  -: KeyChord [             ] NKey
+  , "N"  -: KeyChord [ShiftModifier] NKey
+  , "o"  -: KeyChord [             ] OKey
+  , "O"  -: KeyChord [ShiftModifier] OKey
+  , "p"  -: KeyChord [             ] PKey
+  , "P"  -: KeyChord [ShiftModifier] PKey
+  , "q"  -: KeyChord [             ] QKey
+  , "Q"  -: KeyChord [ShiftModifier] QKey
+  , "r"  -: KeyChord [             ] RKey
+  , "R"  -: KeyChord [ShiftModifier] RKey
+  , "s"  -: KeyChord [             ] SKey
+  , "S"  -: KeyChord [ShiftModifier] SKey
+  , "t"  -: KeyChord [             ] TKey
+  , "T"  -: KeyChord [ShiftModifier] TKey
+  , "u"  -: KeyChord [             ] UKey
+  , "U"  -: KeyChord [ShiftModifier] UKey
+  , "v"  -: KeyChord [             ] VKey
+  , "V"  -: KeyChord [ShiftModifier] VKey
+  , "w"  -: KeyChord [             ] WKey
+  , "W"  -: KeyChord [ShiftModifier] WKey
+  , "x"  -: KeyChord [             ] XKey
+  , "X"  -: KeyChord [ShiftModifier] XKey
+  , "y"  -: KeyChord [             ] YKey
+  , "Y"  -: KeyChord [ShiftModifier] YKey
+  , "z"  -: KeyChord [             ] ZKey
+  , "Z"  -: KeyChord [ShiftModifier] ZKey
+
+  , "0"  -: KeyChord [             ] ZeroKey
+  , ")"  -: KeyChord [ShiftModifier] ZeroKey
+  , "1"  -: KeyChord [             ] OneKey
+  , "!"  -: KeyChord [ShiftModifier] OneKey
+  , "2"  -: KeyChord [             ] TwoKey
+  , "@"  -: KeyChord [ShiftModifier] TwoKey
+  , "3"  -: KeyChord [             ] ThreeKey
+  , "#"  -: KeyChord [ShiftModifier] ThreeKey
+  , "4"  -: KeyChord [             ] FourKey
+  , "$"  -: KeyChord [ShiftModifier] FourKey
+  , "5"  -: KeyChord [             ] FiveKey
+  , "%"  -: KeyChord [ShiftModifier] FiveKey
+  , "6"  -: KeyChord [             ] SixKey
+  , "^"  -: KeyChord [ShiftModifier] SixKey
+  , "7"  -: KeyChord [             ] SevenKey
+  , "&"  -: KeyChord [ShiftModifier] SevenKey
+  , "8"  -: KeyChord [             ] EightKey
+  , "*"  -: KeyChord [ShiftModifier] EightKey
+  , "9"  -: KeyChord [             ] NineKey
+  , "("  -: KeyChord [ShiftModifier] NineKey
+
+  , "`"  -: KeyChord [             ] GraveKey
+  , "~"  -: KeyChord [ShiftModifier] GraveKey
+  , "<dash>"  -: KeyChord [             ] MinusKey 
+  , "-"  -: KeyChord [             ] MinusKey --TODO fails
+  , "_"  -: KeyChord [ShiftModifier] MinusKey
+  , "="  -: KeyChord [             ] EqualKey
+  , "+"  -: KeyChord [ShiftModifier] EqualKey
+  , "["  -: KeyChord [             ] LeftBracketKey
+  , "{"  -: KeyChord [ShiftModifier] LeftBracketKey
+  , "]"  -: KeyChord [             ] RightBracketKey
+  , "}"  -: KeyChord [ShiftModifier] RightBracketKey
+  , "\\" -: KeyChord [             ] BackslashKey
+  , "|"  -: KeyChord [ShiftModifier] BackslashKey
+  , ";"  -: KeyChord [             ] SemicolonKey
+  , ":"  -: KeyChord [ShiftModifier] SemicolonKey
+  , "'"  -: KeyChord [             ] QuoteKey
+  , "\"" -: KeyChord [ShiftModifier] QuoteKey
+  , ","  -: KeyChord [             ] CommaKey
+  , "<"  -: KeyChord [ShiftModifier] CommaKey
+  , "."  -: KeyChord [             ] PeriodKey
+  , ">"  -: KeyChord [ShiftModifier] PeriodKey
+  , "/"  -: KeyChord [             ] SlashKey
+  , "?"  -: KeyChord [ShiftModifier] SlashKey
+  , " "  -: KeyChord [             ] SpaceKey
+  , "\t" -: KeyChord [             ] TabKey
+  , "\n" -: KeyChord [             ] ReturnKey
+
+  , "<spc>"-: SimpleKeyChord SpaceKey
+  , "<tab>"-: SimpleKeyChord TabKey
+  , "<ret>"-: SimpleKeyChord ReturnKey
+  , "<del>"-: SimpleKeyChord DeleteKey
+  , "<esc>"-: SimpleKeyChord EscapeKey
+
+  , "<up>"   -: SimpleKeyChord UpArrowKey
+  , "<down>" -: SimpleKeyChord DownArrowKey
+  , "<left>" -: SimpleKeyChord LeftArrowKey
+  , "<right>"-: SimpleKeyChord RightArrowKey
+
+  , "<f1>" -: SimpleKeyChord F1Key
+  , "<f2>" -: SimpleKeyChord F2Key
+  , "<f3>" -: SimpleKeyChord F3Key
+  , "<f4>" -: SimpleKeyChord F4Key
+  , "<f5>" -: SimpleKeyChord F5Key
+  , "<f6>" -: SimpleKeyChord F6Key
+  , "<f7>" -: SimpleKeyChord F7Key
+  , "<f8>" -: SimpleKeyChord F8Key
+  , "<f9>" -: SimpleKeyChord F9Key
+  , "<f10>"-: SimpleKeyChord F10Key
+  , "<f11>"-: SimpleKeyChord F11Key
+  , "<f12>"-: SimpleKeyChord F12Key
+  , "<f13>"-: SimpleKeyChord F13Key
+  , "<f14>"-: SimpleKeyChord F14Key
+  , "<f15>"-: SimpleKeyChord F15Key
+  , "<f16>"-: SimpleKeyChord F16Key
+  , "<f17>"-: SimpleKeyChord F17Key
+  , "<f18>"-: SimpleKeyChord F18Key
+  , "<f19>"-: SimpleKeyChord F19Key
+  , "<f20>"-: SimpleKeyChord F20Key
+  ]
+
+--------------------------------------------------------------------------------
+
+-- | appends modifiers
+addMods :: [Modifier] -> KeyChord -> KeyChord
+addMods ms kc = foldr addMod kc ms
+
+-- | appends a modifier
+addMod :: Modifier -> KeyChord -> KeyChord
+addMod m (ms, k) = (m:ms, k)
+-- false positive nonexhaustive warning with the KeyChord pattern. fixed in ghc8?
+-- addMod m (KeyChord ms k) = KeyChord (m:ms) k
+
+--------------------------------------------------------------------------------
+
+{-TODO
+
+Is The benefit of avoiding a parser library as a dependency worth the awkwardness?
+
+-}
+
+{- the keychord that would insert the character into the application.
+
+>>> char2keychord '@' :: Maybe KeyChord
+Just ([ShiftModifier], TwoKey)
+
+some characters cannot be represented as keypresses, like some non-printable characters
+(in arbitrary applications, not just the terminal emulator):
+
+>>> char2keychord '\0' :: Maybe KeyChord
+Nothing
+
+prop> case char2keychord c of {  Just ([],_) -> True;  Just ([ShiftModifier],_) -> True;  Nothing -> True;  _ -> False  }
+
+-}
+char2keychord :: (MonadThrow m) => Char -> m KeyChord
+char2keychord c = case c of
+
+ 'a'  -> return $ KeyChord [             ] AKey
+ 'A'  -> return $ KeyChord [ShiftModifier] AKey
+ 'b'  -> return $ KeyChord [             ] BKey
+ 'B'  -> return $ KeyChord [ShiftModifier] BKey
+ 'c'  -> return $ KeyChord [             ] CKey
+ 'C'  -> return $ KeyChord [ShiftModifier] CKey
+ 'd'  -> return $ KeyChord [             ] DKey
+ 'D'  -> return $ KeyChord [ShiftModifier] DKey
+ 'e'  -> return $ KeyChord [             ] EKey
+ 'E'  -> return $ KeyChord [ShiftModifier] EKey
+ 'f'  -> return $ KeyChord [             ] FKey
+ 'F'  -> return $ KeyChord [ShiftModifier] FKey
+ 'g'  -> return $ KeyChord [             ] GKey
+ 'G'  -> return $ KeyChord [ShiftModifier] GKey
+ 'h'  -> return $ KeyChord [             ] HKey
+ 'H'  -> return $ KeyChord [ShiftModifier] HKey
+ 'i'  -> return $ KeyChord [             ] IKey
+ 'I'  -> return $ KeyChord [ShiftModifier] IKey
+ 'j'  -> return $ KeyChord [             ] JKey
+ 'J'  -> return $ KeyChord [ShiftModifier] JKey
+ 'k'  -> return $ KeyChord [             ] KKey
+ 'K'  -> return $ KeyChord [ShiftModifier] KKey
+ 'l'  -> return $ KeyChord [             ] LKey
+ 'L'  -> return $ KeyChord [ShiftModifier] LKey
+ 'm'  -> return $ KeyChord [             ] MKey
+ 'M'  -> return $ KeyChord [ShiftModifier] MKey
+ 'n'  -> return $ KeyChord [             ] NKey
+ 'N'  -> return $ KeyChord [ShiftModifier] NKey
+ 'o'  -> return $ KeyChord [             ] OKey
+ 'O'  -> return $ KeyChord [ShiftModifier] OKey
+ 'p'  -> return $ KeyChord [             ] PKey
+ 'P'  -> return $ KeyChord [ShiftModifier] PKey
+ 'q'  -> return $ KeyChord [             ] QKey
+ 'Q'  -> return $ KeyChord [ShiftModifier] QKey
+ 'r'  -> return $ KeyChord [             ] RKey
+ 'R'  -> return $ KeyChord [ShiftModifier] RKey
+ 's'  -> return $ KeyChord [             ] SKey
+ 'S'  -> return $ KeyChord [ShiftModifier] SKey
+ 't'  -> return $ KeyChord [             ] TKey
+ 'T'  -> return $ KeyChord [ShiftModifier] TKey
+ 'u'  -> return $ KeyChord [             ] UKey
+ 'U'  -> return $ KeyChord [ShiftModifier] UKey
+ 'v'  -> return $ KeyChord [             ] VKey
+ 'V'  -> return $ KeyChord [ShiftModifier] VKey
+ 'w'  -> return $ KeyChord [             ] WKey
+ 'W'  -> return $ KeyChord [ShiftModifier] WKey
+ 'x'  -> return $ KeyChord [             ] XKey
+ 'X'  -> return $ KeyChord [ShiftModifier] XKey
+ 'y'  -> return $ KeyChord [             ] YKey
+ 'Y'  -> return $ KeyChord [ShiftModifier] YKey
+ 'z'  -> return $ KeyChord [             ] ZKey
+ 'Z'  -> return $ KeyChord [ShiftModifier] ZKey
+
+ '0'  -> return $ KeyChord [             ] ZeroKey
+ ')'  -> return $ KeyChord [ShiftModifier] ZeroKey
+ '1'  -> return $ KeyChord [             ] OneKey
+ '!'  -> return $ KeyChord [ShiftModifier] OneKey
+ '2'  -> return $ KeyChord [             ] TwoKey
+ '@'  -> return $ KeyChord [ShiftModifier] TwoKey
+ '3'  -> return $ KeyChord [             ] ThreeKey
+ '#'  -> return $ KeyChord [ShiftModifier] ThreeKey
+ '4'  -> return $ KeyChord [             ] FourKey
+ '$'  -> return $ KeyChord [ShiftModifier] FourKey
+ '5'  -> return $ KeyChord [             ] FiveKey
+ '%'  -> return $ KeyChord [ShiftModifier] FiveKey
+ '6'  -> return $ KeyChord [             ] SixKey
+ '^'  -> return $ KeyChord [ShiftModifier] SixKey
+ '7'  -> return $ KeyChord [             ] SevenKey
+ '&'  -> return $ KeyChord [ShiftModifier] SevenKey
+ '8'  -> return $ KeyChord [             ] EightKey
+ '*'  -> return $ KeyChord [ShiftModifier] EightKey
+ '9'  -> return $ KeyChord [             ] NineKey
+ '('  -> return $ KeyChord [ShiftModifier] NineKey
+
+ '`'  -> return $ KeyChord [             ] GraveKey
+ '~'  -> return $ KeyChord [ShiftModifier] GraveKey
+ '-'  -> return $ KeyChord [             ] MinusKey
+ '_'  -> return $ KeyChord [ShiftModifier] MinusKey
+ '='  -> return $ KeyChord [             ] EqualKey
+ '+'  -> return $ KeyChord [ShiftModifier] EqualKey
+ '['  -> return $ KeyChord [             ] LeftBracketKey
+ '{'  -> return $ KeyChord [ShiftModifier] LeftBracketKey
+ ']'  -> return $ KeyChord [             ] RightBracketKey
+ '}'  -> return $ KeyChord [ShiftModifier] RightBracketKey
+ '\\' -> return $ KeyChord [             ] BackslashKey
+ '|'  -> return $ KeyChord [ShiftModifier] BackslashKey
+ ';'  -> return $ KeyChord [             ] SemicolonKey
+ ':'  -> return $ KeyChord [ShiftModifier] SemicolonKey
+ '\'' -> return $ KeyChord [             ] QuoteKey
+ '"'  -> return $ KeyChord [ShiftModifier] QuoteKey
+ ','  -> return $ KeyChord [             ] CommaKey
+ '<'  -> return $ KeyChord [ShiftModifier] CommaKey
+ '.'  -> return $ KeyChord [             ] PeriodKey
+ '>'  -> return $ KeyChord [ShiftModifier] PeriodKey
+ '/'  -> return $ KeyChord [             ] SlashKey
+ '?'  -> return $ KeyChord [ShiftModifier] SlashKey
+ ' '  -> return $ KeyChord [             ] SpaceKey
+ '\t' -> return $ KeyChord [             ] TabKey
+ '\n' -> return $ KeyChord [             ] ReturnKey
+
+ _    -> failed $ "{{ char2keychord "++(show c)++" }} not an ASCII, printable character"
+

+ sources/Workflow/Parser.hs view

@@ -0,0 +1,146 @@+{-# LANGUAGE LambdaCase, ScopedTypeVariables, RankNTypes #-}
+
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+
+{-| A command line interface for manual integration testing.
+
+
+-}
+module Workflow.Parser where
+import Workflow.Core
+
+import Text.Earley as E
+
+import Control.Applicative
+import Control.Arrow
+import Data.Char
+import Data.Function
+import System.IO
+import Control.Monad.IO.Class
+
+
+{-|
+
+-}
+type ExecuteWorkflow = forall x. WorkflowT IO x -> IO x
+  -- forall x. Workflow x -> IO x
+  -- No instance for (MonadThrow (Control.Monad.Free.Free WorkflowF)) arising from a use of ‘press’
+
+type Workflow' = WorkflowT IO ()
+
+data Action
+ = Quit
+ | Help
+ | Stay (Workflow')
+ | Pause Int (Workflow')
+ | Action (Workflow')
+
+-- Maybe (IO ())
+
+{- |
+
+prefix with a number to pause (for that many seconds) before execution.
+
+prefix with "stay" to disable "alt-tab"ing before execution.
+
+e.g.
+
+@
+> help
+...
+> stay paste
+> copy                   # (Having selected some text topmost (besides the current) window)
+> 1000 paste             # Wait a second before pasting
+> quit
+@
+
+-}
+cmdln :: ExecuteWorkflow -> IO ()
+cmdln runWorkflow = do
+ hSetBuffering stdout NoBuffering
+ go
+
+ where
+
+ go = do
+   putStr prompt
+   s <- getLine
+   (evalAction runWorkflow) s & \case
+     Nothing -> return ()
+     Just io -> do
+       io
+       go
+
+ prompt = "> "
+
+evalAction :: ExecuteWorkflow -> String -> Maybe (IO ())
+evalAction runWorkflow = parseAction >>> runAction runWorkflow
+
+runAction :: ExecuteWorkflow -> Action -> Maybe (IO ())
+runAction runWorkflow = \case
+ Quit -> Nothing
+ Help -> Just help
+
+ Stay w -> Just $ runWorkflow $ do
+   w
+
+ Pause t w -> Just $ runWorkflow $ do
+   delay (t*1000)
+   w
+
+ Action w -> Just $ runWorkflow $ do
+   press "H-<tab>"
+   delay 300
+   w
+
+help = do
+  putStrLn "help" --TODO
+
+parseAction :: String -> Action
+parseAction s = case fst (p (words s)) of
+  (a:_) -> a
+  _ -> Help
+ where
+ p = E.fullParses (E.parser gAction)
+--parseAction s = case fst (E.parser (E.fullParses gAction) s) of
+
+--gAction :: E.Grammar r Action
+gAction = do
+
+ let pWord = E.satisfy (const True)
+ pWords :: E.Prod r e String String <- E.rule $
+  unwords <$> some pWord
+
+ int <- E.rule $
+  read <$> E.satisfy (all isDigit)
+
+ pWorkflow :: E.Prod r e String Workflow' <- E.rule $ empty
+
+  <|> (readEmacsKeySequence >>> maybe (return()) sendKeySequence) <$ E.token "press" <*> pWords
+  <|> (sendText) <$ E.token "insert" <*> pWords
+
+  <|> (getClipboard >>= (liftIO . putStrLn)) <$ E.token "getClipboard"
+  <|> (setClipboard) <$ E.token "setClipboard" <*> pWords
+
+  -- <|> () <$> E.token ""
+  -- <|> () <$> E.token ""
+
+  <|> (currentApplication >>= (liftIO . putStrLn)) <$ E.token "currentApplication"
+  <|> (openApplication) <$ E.token "open" <*> pWords
+  <|> (openURL) <$ E.token "url" <*> pWords
+
+  <|> (getClipboard >>= sendText) <$ E.token "paste"
+--  <|> () <$> E.token ""
+
+  -- <|> pure (E.token "paste") *> do
+  --     getClipboard >>= sendText
+
+ -- pAction :: E.Prod r e String Action <- E.rule $ empty
+ pAction <- E.rule $ empty
+  <|> Quit <$ E.token "quit"
+  <|> Help <$ E.token "help"
+  <|> Stay   <$ E.token "stay" <*> pWorkflow
+  <|> Pause  <$> int <*> pWorkflow
+  <|> Action <$> pWorkflow
+
+ return pAction

+ sources/Workflow/Reexports.hs view

@@ -0,0 +1,7 @@+-- | 
+module Workflow.Reexports
+ ( MonadThrow
+ , MonadFree
+ ) where
+import Control.Monad.Catch (MonadThrow)
+import Control.Monad.Free (MonadFree)

+ sources/Workflow/Types.hs view

@@ -0,0 +1,606 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts, PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- {-# OPTIONS_GHC -ddump-splices #-}
+-- for `makeFree`
+
+{-|
+
+-}
+module Workflow.Types where
+import Workflow.Extra
+
+import Control.Monad.Trans.Free (FreeT)
+import Control.Comonad.Trans.Cofree (CofreeT)
+-- import Control.Monad.Free.Church  (F)
+import           Control.Monad.Free          (MonadFree, Free, liftF)
+import           Control.Monad.Free.TH       (makeFree)
+import           Control.Comonad.Cofree (Cofree)
+-- import Control.Comonad
+
+import Numeric.Natural
+--import GHC.Exts
+
+--------------------------------------------------------------------------------
+{-$ WorkflowF
+-}
+
+{-|
+
+-}
+
+{- | platform-agnostic workflows,
+which can be interpreted by platform-specific bindings.
+
+Naming: "WorkflowF" for "Workflow Functor".
+
+NOTE: currently, no error codes are returned (only @()@)).
+this (1) simplifies bindings and
+(2) saves the user from explicitly ignoring action results (e.g. @_ <- getClipboard@).
+later, they can be supported,
+alongside wrappers that return @()@ and throw @SomeException@
+and provide the same simple API.
+since the intented usage of workflows are as user-facing
+(often user-written) scripts, and
+the monad that satisifes MonadWorkflow will often satisify MonadIO too,
+convenient partial functions that throw a helpful error message to stdout
+(the error codes should be converted to their error messages) should suffice.
+and either way, is strictly better for the user than ignoring,
+as the exceptions can always be caught, or not displayed.
+
+-}
+data WorkflowF k
+ = SendKeyChord    [Modifier] Key                  k -- ^ press the 'Key' while the 'Modifier's are held down. sent to the current application.
+ --TODO | SendKeyChordTo Application    [Modifier] Key                   k -- ^
+ --TODO | SendKeyChordTo Window    [Modifier] Key                   k -- ^
+ -- versus unary: ([Modifier], Key)
+ -- rn SendChord
+
+ | SendText        String                          k -- ^ a logical grouping for: (1) unicode support (2) efficiency and (3) debugging. sent to the current application.
+
+ --TODO | SendTextTo Application        String                           k -- ^
+ --TODO | SendTextTo Window        String                           k -- ^
+ -- sendText = sendTextTo =<< currentApplication
+
+ | SendMouseClick  [Modifier] Natural MouseButton  k  -- ^ click the button, some number of times, holding down the modifiers
+  -- derived, make method, not constructor. sent to the current application.
+
+
+ --TODO | SendMouseClickTo Application  [Modifier] Int MouseButton  k  ^ -- sent to the current application.
+ -- versus unary: ([Modifier], Natural, MouseButton)
+ | SendMouseScroll  [Modifier] MouseScroll Natural  k  -- ^ spin the wheel, some number of units*, holding down the modifiers
+
+ | GetClipboard                                     (Clipboard -> k)
+ | SetClipboard       Clipboard                     k
+
+ | CurrentApplication                               (Application -> k) -- ^ like getter
+ | OpenApplication    Application                   k                  -- ^ like setter
+
+ --TODO | GetApplications ([Application] -> k)
+
+ --TODO | CurrentWindow                               (Window -> k)
+ --TODO | ReachWindow Window                      k
+ --TODO | GetWindows        Application                       ([Window] -> k)   -- ^ an 'Application' has some 'Window's (zero or more on OSX, one or more on Windows/Linux, I think).
+
+ | OpenURL         URL                              k
+
+ | Delay           MilliSeconds                             k -- ^ interpreted as 'threadDelay' on all platforms; included for convenience
+
+ deriving (Functor)
+ -- deriving (Functor,Data)
+
+--------------------------------------------------------------------------------
+
+{-| the non-monadic subset of 'WorkflowF'.
+i.e. all cases that return @()@, preserving the previous continuation.
+
+Naming: "unit workflow", like "traverse_".
+
+-}
+data Workflow_
+ = SendKeyChord_    [Modifier] Key
+ | SendText_        String
+ | SendMouseClick_  [Modifier] Natural MouseButton
+ | SendMouseScroll_ [Modifier] MouseScroll Natural
+ | SetClipboard_    Clipboard
+ | OpenApplication_ Application
+ | OpenURL_         URL
+ | Delay_           MilliSeconds
+
+ deriving (Show,Read,Eq,Ord,Data,Generic)
+instance NFData Workflow_
+
+--------------------------------------------------------------------------------
+
+{- | abstract interface.
+
+a monad constraint for "workflow effects"
+(just like @MonadState@ is for "state effects").
+Can be used in any monad transformer stack that handles them.
+
+'WorkflowF' holds the effects.
+
+'MonadThrow' supports:
+
+* 'Workflow.Keys.press', if the user's syntax is wrong
+* error messages from the underlying system calls (TODO e.g. Win32's @GetLastError()@)
+
+-}
+type MonadWorkflow m = (MonadFree WorkflowF m, MonadThrow m)
+
+-- | (without failability)
+type MonadWorkflow_ = MonadFree WorkflowF
+
+{-old
+type MonadWorkflow_ m = (MonadFree WorkflowF m)
+
+without eta-contract:
+        Illegal deriving item ‘MonadWorkflow_’
+-}
+
+--NOTE MonadThrow for `press`.
+-- but, does instance MonadThrow (FreeT f m) exist? depends on f?
+-- yes! depends on m. instance (Functor f, MonadThrow m) => MonadThrow (FreeT f m)
+
+-- class (MonadFree WorkflowF m, MonadThrow m) => MonadWorkflow where
+-- like `newtype` for constraints
+-- less automatic
+
+-- {- | for convenience.
+-- without loss of generality (I don't think) when declaring simple monadic effects (like Kleisli arrows).
+
+-- e.g.
+
+-- @
+-- getClipboard :: 'AMonadWorkflow'      String  -- generalized
+-- getClipboard :: ('MonadWorkflow' m) => m String  -- generalized
+-- getClipboard :: Free 'WorkflowF'         String  -- specialized
+-- @
+
+-- -}
+-- type AMonadWorkflow a = forall m. (MonadWorkflow m) => m a
+
+-- {-| Naming: "a unit monad workflow".
+-- -}
+-- type AMonadWorkflow_ = (forall m. (MonadWorkflow m) => m ())
+
+-- | concrete transformer.
+type WorkflowT = FreeT WorkflowF
+
+-- | concrete monad.
+type Workflow = Free WorkflowF
+
+--------------------------------------------------------------------------------
+
+type Clipboard = String
+
+type Application = String
+
+type URL = String
+
+type MilliSeconds = Int
+-- newtype Time = Time Int  deriving (Show,Eq,Ord,Num)
+-- units package
+-- milliseconds
+
+-- class IsString TODO needs Free WorkflowF, which must be lifted,
+-- which isn't better than an explicit insert
+
+
+-- {-|
+--
+-- >>> :set -XOverloadedStrings
+-- >>> "contents" :: Clipboard
+-- "contents"
+--
+-- -}
+--newtype Clipboard_ = Clipboard String
+ --deriving (Show,Read,Eq,Ord,IsString,Data,Generic,Semigroup,NFData)
+-- data Clipboard = Clipboard { cbContents :: String, cbFormat :: ClipboardFormat }
+-- instance IsString UnicodeTextFormat where fromString s = Clipboard s UnicodeTextFormat
+-- GetClipboardContents
+-- getClipboard = getClipboardContents<&>cbContents
+-- runWorkflow must take a mapping (ClipboardFormat -> something)
+--  maybe: phantom data RawClipboard (format :: ClipboardFormat) = Bytestring
+--  with reflection class KnownClipboardFormat
+
+-- {-|
+--
+-- >>> :set -XOverloadedStrings
+-- >>> "Emacs" :: Application
+-- "Emacs"
+--
+-- -}
+--newtype Application_ = Application String
+ --deriving (Show,Read,Eq,Ord,IsString,Data,Generic,Semigroup,NFData)
+
+-- {-|
+--
+-- >>> :set -XOverloadedStrings
+-- >>> "https://google.com/" :: URL
+-- "https://google.com/"
+--
+-- -}
+--newtype URL_ = URL String
+  --deriving (Show,Read,Eq,Ord,IsString,Data,Generic,Semigroup,NFData)
+--TODO refined
+
+--------------------------------------------------------------------------------
+
+{-| Operating systems always (?) support at least these mouse events.
+
+Most mice have these three buttons, trackpads have left/right.
+
+-}
+data MouseButton
+ = LeftButton
+ | MiddleButton
+ | RightButton
+ --TODO | XButton -- https://msdn.microsoft.com/en-us/library/windows/desktop/gg153549(v=vs.85).aspx
+ deriving (Show,Read,Eq,Ord,Enum,Bounded,Data,Generic)
+instance NFData MouseButton
+
+{-| Mouse wheel scrolling, vertically and horizontally.
+
+'ScrollTowards':
+
+* scrolls up when "natural scrolling" is disabled
+* scrolls down when "natural scrolling" is enabled
+
+TODO check
+
+-}
+data MouseScroll
+  = ScrollTowards -- ScrollUp (from user)
+  | ScrollAway -- ScrollDown (from user)
+  | ScrollLeft
+  | ScrollRight
+  deriving (Show,Read,Eq,Ord,Enum,Bounded,Data,Generic)
+instance NFData MouseScroll
+
+--------------------------------------------------------------------------------
+
+-- {-| Represents @a@ being bound to a keyboard shortcut.
+--
+-- Naming:
+-- <https://www.gnu.org/software/emacs/manual/html_node/elisp/Key-Binding-Commands.html>
+--
+-- -}
+-- data KeyBinding a = KeyBinding KeySequence a
+--TODO mv to commands-core or something
+
+{-| a sequence of key chords make up a keyboard shortcut
+
+Naming:
+<https://www.emacswiki.org/emacs/KeySequence>
+
+-}
+type KeySequence = [KeyChord]
+-- newtype KeySequence = KeySequence (NonEmpty KeyChord)
+--
+--TODO newtype for non-overlapping IsString
+-- instance IsString KCs where fromString =
+-- --TODO refined
+--
+-- press :: KCs -> m()
+--
+
+-- an (unordered, no-duplicates) sequence of key
+-- chords make up a keyboard shortcut
+-- not a Set for simplicity (e.g. to avoid imports and Ord constraints).
+--really?
+
+{- | represents joitly holding down all the modifiers
+while individually press each key down and back up.
+
+Naming: https://www.emacswiki.org/emacs/Chord
+
+-}
+type KeyChord = ([Modifier], Key)
+-- data KeyChord = KeyChord [Modifier] Key
+{- data KeyChord = KeyChord
+ { kcModifiers :: [Modifier]
+ , kcKey       :: Key
+ }
+-}
+
+-- | @pattern KeyChord ms k = (ms,k)@
+pattern KeyChord :: [Modifier] -> Key -> KeyChord
+pattern KeyChord ms k = (ms, k)
+
+pattern SimpleKeyChord :: Key -> KeyChord
+pattern SimpleKeyChord k = ([], k)
+
+{- | modifier keys are keys that can be "held".
+
+NOTE the escape key tends to be "pressed", not "held", it seems.
+(possibly explains its behavior in your terminal emulator?)
+
+@alt@ is 'OptionModifier'.
+
+-}
+data Modifier
+ = MetaModifier  -- ^ fake modifier: Alt on Linux\/Windows, Command on OSX
+ | HyperModifier -- ^ fake modifier: Control on Linux\/Windows, Command on OSX
+ | ControlModifier
+ | OptionModifier --TODO rn Option Alt
+ | ShiftModifier
+ | FunctionModifier
+ deriving (Show,Read,Eq,Ord,Bounded,Enum,Data,Generic)
+instance NFData Modifier
+
+{- | a "cross-platform" keyboard, that has:
+
+* all keys that exist on standard keyboards.
+* plus, 'MetaKey' and 'HyperKey': virtual modifiers to abstract over
+common keyboard shortcuts.
+
+(let me know if you want a type to support cross-platform international keyboards,
+i haven't looked into it. you can still use the
+platform-specific virtual-key-codes in the dependent packages:
+@workflow-linux@, @workflow-osx@, and @workflow-windows@)
+
+-}
+data Key
+
+ = MetaKey -- ^ fake key: Alt on Linux\/Windows, Command on OSX
+ | HyperKey -- ^ fake key: Control on Linux\/Windows, Command on OSX
+-- Control/Command both have C\/O\/N
+
+ | ControlKey
+ | CapsLockKey
+ | ShiftKey
+ | OptionKey
+ | FunctionKey
+
+ | GraveKey
+ | MinusKey
+ | EqualKey
+ | DeleteKey
+ | ForwardDeleteKey
+ | LeftBracketKey
+ | RightBracketKey
+ | BackslashKey
+ | SemicolonKey
+ | QuoteKey
+ | CommaKey
+ | PeriodKey
+ | SlashKey
+
+ | TabKey
+ | SpaceKey
+ | ReturnKey
+
+ | LeftArrowKey
+ | RightArrowKey
+ | DownArrowKey
+ | UpArrowKey
+
+ | AKey
+ | BKey
+ | CKey
+ | DKey
+ | EKey
+ | FKey
+ | GKey
+ | HKey
+ | IKey
+ | JKey
+ | KKey
+ | LKey
+ | MKey
+ | NKey
+ | OKey
+ | PKey
+ | QKey
+ | RKey
+ | SKey
+ | TKey
+ | UKey
+ | VKey
+ | WKey
+ | XKey
+ | YKey
+ | ZKey
+
+ | ZeroKey
+ | OneKey
+ | TwoKey
+ | ThreeKey
+ | FourKey
+ | FiveKey
+ | SixKey
+ | SevenKey
+ | EightKey
+ | NineKey
+
+ | EscapeKey
+ | F1Key
+ | F2Key
+ | F3Key
+ | F4Key
+ | F5Key
+ | F6Key
+ | F7Key
+ | F8Key
+ | F9Key
+ | F10Key
+ | F11Key
+ | F12Key
+ | F13Key
+ | F14Key
+ | F15Key
+ | F16Key
+ | F17Key
+ | F18Key
+ | F19Key
+ | F20Key
+
+ deriving (Show,Read,Eq,Ord,Bounded,Enum,Data,Generic)
+instance NFData Key
+
+-- | All modifiers are keys.
+modifier2key :: Modifier -> Key
+modifier2key = \case
+ MetaModifier          -> MetaKey
+ HyperModifier         -> HyperKey
+ ShiftModifier         -> ShiftKey
+ OptionModifier        -> OptionKey
+ ControlModifier       -> ControlKey
+ FunctionModifier      -> FunctionKey
+
+--------------------------------------------------------------------------------
+makeFree ''WorkflowF
+-- th staging: the spilce can only access previous declarations
+
+-- | @= 'traverse_' 'sendKeyChord''@
+sendKeySequence :: (MonadWorkflow m) => KeySequence -> m ()
+sendKeySequence = traverse_ sendKeyChord'
+
+-- | uncurried 'sendKeyChord'
+sendKeyChord' :: (MonadWorkflow m) => KeyChord -> m ()
+sendKeyChord' (ms,k) = sendKeyChord ms k
+
+--------------------------------------------------------------------------------
+
+fromWorkflows_ :: (MonadWorkflow m) => [Workflow_] -> m ()
+fromWorkflows_ = traverse_ (liftF . fromWorkflow_)
+
+fromWorkflow_ :: Workflow_ -> WorkflowF ()
+-- fromWorkflow_ :: (MonadWorkflow m) => Workflow_ -> m ()
+fromWorkflow_ = \case
+  SendKeyChord_    flags key      -> SendKeyChord     flags key      ()
+  SendText_        s              -> SendText         s              ()
+  SendMouseClick_  flags n button -> SendMouseClick   flags n button ()
+  SendMouseScroll_ flags scroll n -> SendMouseScroll  flags scroll n ()
+  SetClipboard_    s              -> SetClipboard     s              ()
+  OpenApplication_ app            -> OpenApplication  app            ()
+  OpenURL_         url            -> OpenURL          url            ()
+  Delay_           t              -> Delay            t              ()
+
+--------------------------------------------------------------------------------
+{-$ CoWorkflowF
+
+provides generic helper functions for defining interpreters.
+
+-}
+
+{-|
+
+Naming: induces a @CoMonad@, see
+<http://dlaing.org/cofun/posts/free_and_cofree.html>
+
+'WorkflowF', 'CoWorkflowF', and 'runWorkflowWithT' are analogous to:
+
+* @Either (a -> c) (b,c)@,
+"get an @a@, or set a @b@"
+* @((a,c), (b -> c))@,
+"a handler for the getting of an @a@, and a handler for the setting of a @b@"
+* @
+handle
+ :: ((a,c), (b -> c))
+ -> (Either (a -> c) (b,c))
+ -> c
+handle (aHasBeenGotten, bHasBeenSet) = either TODO
+@
+
+background: see
+<http://dlaing.org/cofun/posts/free_and_cofree.html>
+
+-}
+data CoWorkflowF k = CoWorkflowF
+   { _SendKeyChord       :: ([Modifier] -> Key -> k)
+   , _SendText           :: (String            -> k)
+
+   , _SendMouseClick     :: ([Modifier] -> Natural     -> MouseButton -> k)
+   , _SendMouseScroll    :: ([Modifier] -> MouseScroll -> Natural     -> k)
+
+   , _GetClipboard       :: (Clipboard  , k)
+   , _SetClipboard       :: (Clipboard -> k)
+
+   , _CurrentApplication :: (Application  , k)
+   , _OpenApplication    :: (Application -> k)
+
+   , _OpenURL            :: (URL -> k)
+
+   , _Delay              :: (MilliSeconds -> k)
+
+   } deriving (Functor)
+
+{-
+
+class (Functor f, Functor g) => Pairing f g where
+ pair :: (a -> b -> r) -> (f a -> g b -> r)
+
+instance Pairing CoWorkflowF WorkflowF where
+ pair :: (a -> b -> r) -> (CoWorkflowF a -> WorkflowF b -> r)
+
+ pair u CoWorkflowF{..} = \case
+
+  GetClipboard f    -> let (s,a) = _getClipboard in
+                       u a (f s)
+
+  SetClipboard s b  -> u (_setClipboard s) b
+
+  ...
+
+
+  pairEffect :: (Pairing f g, Comonad w, Monad m)
+             => (a -> b -> r) -> CofreeT f w a -> FreeT g m b -> m r
+  pairEffect p s c = do
+
+
+
+-}
+
+{-|
+
+e.g.
+
+@
+@
+
+expansion:
+
+@
+CoWorkflowT w a
+~
+CofreeT CoWorkflowF w a
+~
+w (CofreeF CoWorkflowF a (CofreeT CoWorkflowF w a))
+~
+w (a, CoWorkflowF (CofreeT CoWorkflowF w a))
+@
+
+since:
+
+@
+data CofreeT f w a = w (CofreeF f a (CofreeT f w a))
+@
+
+-}
+type CoWorkflowT = CofreeT CoWorkflowF
+
+{-|
+
+expansion:
+
+@
+CoWorkflow a
+~
+Cofree CoWorkflowF a
+~
+(a, CoWorkflow (Cofree CoWorkflowF a))
+@
+
+since:
+
+@
+data Cofree f a = a :< f (Cofree f a)
+@
+
+-}
+type CoWorkflow = Cofree CoWorkflowF
+
+--------------------------------------------------------------------------------

+ workflow-types.cabal view

@@ -0,0 +1,69 @@+name:                workflow-types
+version:             0.0.0
+synopsis:            Automate keyboard\/mouse\/clipboard\/application interaction.
+description:         TODO
+homepage:            http://github.com/sboosali/workflow-types#readme
+license:             BSD3
+license-file:        LICENSE
+author:              Spiros Boosalis
+maintainer:          samboosalis@gmail.com
+copyright:           2016 Spiros Boosalis
+category:            Development
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+source-repository head
+  type:     git
+  location: https://github.com/sboosali/workflow-types
+
+
+library
+ hs-source-dirs:      sources
+ default-language:    Haskell2010
+ ghc-options:
+  -Wall
+  -fno-warn-unticked-promoted-constructors
+ default-extensions: AutoDeriveTypeable DeriveDataTypeable DeriveGeneric
+                     DeriveFunctor DeriveFoldable DeriveTraversable
+                     LambdaCase EmptyDataDecls TypeOperators BangPatterns Arrows
+                     MultiWayIf DoAndIfThenElse PostfixOperators TupleSections
+                     MultiParamTypeClasses FlexibleContexts FlexibleInstances
+                     TypeFamilies FunctionalDependencies
+                     ExplicitForAll StandaloneDeriving
+
+ exposed-modules:
+  Workflow.Core
+  Workflow.Types
+  Workflow.Execute
+  Workflow.Keys
+  Workflow.Reexports
+
+ -- other-modules:
+  Workflow.Extra
+  Workflow.Example
+  Workflow.Parser
+
+ build-depends:
+    base >=4.7 && <5
+  , transformers
+  , containers
+
+  , deepseq
+  , hashable
+  , semigroups
+  , split
+  , free
+  , comonad
+  , exceptions
+
+  , Earley
+
+
+executable workflow-types-example
+   main-is:             Main.hs
+   hs-source-dirs:      executables
+   default-language:    Haskell2010
+   build-depends:
+       base
+     , workflow-types