workflow-pure (empty) → 0.0.0
raw patch · 19 files changed
+822/−0 lines, 19 filesdep +QuickCheckdep +basedep +criterionsetup-changed
Dependencies added: QuickCheck, base, criterion, deepseq, doctest, exceptions, free, hspec, mtl, semigroups, transformers, workflow-pure, workflow-types
Files
- .gitignore +34/−0
- .travis.yml +14/−0
- HLint.hs +9/−0
- LICENSE +31/−0
- README.md +6/−0
- Setup.hs +3/−0
- benchmarks/Bench.hs +10/−0
- executables/Main.hs +4/−0
- sources/Workflow/Pure.hs +15/−0
- sources/Workflow/Pure/Char.hs +293/−0
- sources/Workflow/Pure/Execute.hs +180/−0
- sources/Workflow/Pure/Extra.hs +30/−0
- sources/Workflow/Pure/Main.hs +16/−0
- sources/Workflow/Pure/Types.hs +1/−0
- stack.yaml +15/−0
- tests/DocTest.hs +7/−0
- tests/UnitTest.hs +2/−0
- tests/Workflow/Pure/Test.hs +5/−0
- workflow-pure.cabal +147/−0
+ .gitignore view
@@ -0,0 +1,34 @@+# my+ignore/+notes+goals+TODO+cbits/main+.projectile++# Haskell+dist+cabal-dev+*.o+*.hi+*.chi+*.chs.h+.virtualenv+.hsenv+.cabal-sandbox/+cabal.sandbox.config+cabal.config+report.html+.stack-work/++# Emacs+\#*+*~+.#*+\#*\#+*.log+TAGS++# OS X+.DS_Store+
+ .travis.yml view
@@ -0,0 +1,14 @@+# https://docs.travis-ci.com/user/languages/haskell++# - 8.0+ghc:+ - 7.10+ - 7.8++# install: stack install++# script: stack test++notifications:+ email:+ - samboosalis@gmail.com
+ HLint.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE PackageImports, TemplateHaskell #-}+import "hint" HLint.Default+import "hint" HLint.Dollar+import "hint" HLint.Generalise+ignore "Use unwords"+ignore "Use map once"+ignore "Use =<<"+ignore "Functor law"+
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Spiros Boosalis (c) 2015++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Spiros Boosalis nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ README.md view
@@ -0,0 +1,6 @@+[](http://travis-ci.org/sboosali/workflow-pure)+[](https://hackage.haskell.org/package/workflow-pure)++# workflow-pure++TODO
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ benchmarks/Bench.hs view
@@ -0,0 +1,10 @@+import Workflow/Pure()+import Criterion.Main++main = defaultMain [+ bgroup "Workflow/Pure"+ [ bench "1" $ nf length [1..1000::Int]+ , bench "2" $ whnf length [1..1000::Int]+ ]+ ]+
+ executables/Main.hs view
@@ -0,0 +1,4 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+import qualified Workflow.Pure.Main++main = Workflow.Pure.Main.main
+ sources/Workflow/Pure.hs view
@@ -0,0 +1,15 @@+{-| pure interpretations:++* downcast workflows to lists of actions+* display workflows by patching system variables++-}+--TODO * run workflows with a crude model of the os+module Workflow.Pure+ ( module Workflow.Pure.Types+ , module Workflow.Pure.Execute+ , module Workflow.Pure.Char+ ) where+import Workflow.Pure.Types+import Workflow.Pure.Execute+import Workflow.Pure.Char
+ sources/Workflow/Pure/Char.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE LambdaCase, ScopedTypeVariables #-}+module Workflow.Pure.Char where+import Workflow.Types+import Workflow.Pure.Extra+++{- |++>>> int2keychord -12+[([],MinusKey),([],OneKey),([],TwoKey)]+++-}+int2keychord :: Integer -> [KeyChord]+int2keychord = concatMap char2keychord . show++{- |++a (base ten) digit is a number between zero and nine inclusive.++>>> digit2keychord 2+([],TwoKey)++>>> digit2keychord -2+Nothing++>>> digit2keychord 12+Nothing++-}+digit2keychord :: (MonadThrow m, Num a, Eq a, Show a) => a -> m KeyChord++digit2keychord 0 = return $ SimpleKeyChord ZeroKey+digit2keychord 1 = return $ SimpleKeyChord OneKey+digit2keychord 2 = return $ SimpleKeyChord TwoKey+digit2keychord 3 = return $ SimpleKeyChord ThreeKey+digit2keychord 4 = return $ SimpleKeyChord FourKey+digit2keychord 5 = return $ SimpleKeyChord FiveKey+digit2keychord 6 = return $ SimpleKeyChord SixKey+digit2keychord 7 = return $ SimpleKeyChord SevenKey+digit2keychord 8 = return $ SimpleKeyChord EightKey+digit2keychord 9 = return $ SimpleKeyChord NineKey++digit2keychord k = failed $+ "digit2keychord: digits must be between zero and nine: " ++ show k++--note matching on generic numeric literals demands (Num a, Eq a)+++{- | the keychord that would insert the character into the application.++>>> char2keychord '@' :: Maybe KeyChord+Just ([ShiftModifier], TwoKey)++some characters cannot be represented as keychordes, 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 -- (KeyChord [Modifier] Key)++char2keychord 'a' = return $ (,) [] AKey+char2keychord 'A' = return $ (,) [ShiftModifier] AKey+char2keychord 'b' = return $ (,) [] BKey+char2keychord 'B' = return $ (,) [ShiftModifier] BKey+char2keychord 'c' = return $ (,) [] CKey+char2keychord 'C' = return $ (,) [ShiftModifier] CKey+char2keychord 'd' = return $ (,) [] DKey+char2keychord 'D' = return $ (,) [ShiftModifier] DKey+char2keychord 'e' = return $ (,) [] EKey+char2keychord 'E' = return $ (,) [ShiftModifier] EKey+char2keychord 'f' = return $ (,) [] FKey+char2keychord 'F' = return $ (,) [ShiftModifier] FKey+char2keychord 'g' = return $ (,) [] GKey+char2keychord 'G' = return $ (,) [ShiftModifier] GKey+char2keychord 'h' = return $ (,) [] HKey+char2keychord 'H' = return $ (,) [ShiftModifier] HKey+char2keychord 'i' = return $ (,) [] IKey+char2keychord 'I' = return $ (,) [ShiftModifier] IKey+char2keychord 'j' = return $ (,) [] JKey+char2keychord 'J' = return $ (,) [ShiftModifier] JKey+char2keychord 'k' = return $ (,) [] KKey+char2keychord 'K' = return $ (,) [ShiftModifier] KKey+char2keychord 'l' = return $ (,) [] LKey+char2keychord 'L' = return $ (,) [ShiftModifier] LKey+char2keychord 'm' = return $ (,) [] MKey+char2keychord 'M' = return $ (,) [ShiftModifier] MKey+char2keychord 'n' = return $ (,) [] NKey+char2keychord 'N' = return $ (,) [ShiftModifier] NKey+char2keychord 'o' = return $ (,) [] OKey+char2keychord 'O' = return $ (,) [ShiftModifier] OKey+char2keychord 'p' = return $ (,) [] PKey+char2keychord 'P' = return $ (,) [ShiftModifier] PKey+char2keychord 'q' = return $ (,) [] QKey+char2keychord 'Q' = return $ (,) [ShiftModifier] QKey+char2keychord 'r' = return $ (,) [] RKey+char2keychord 'R' = return $ (,) [ShiftModifier] RKey+char2keychord 's' = return $ (,) [] SKey+char2keychord 'S' = return $ (,) [ShiftModifier] SKey+char2keychord 't' = return $ (,) [] TKey+char2keychord 'T' = return $ (,) [ShiftModifier] TKey+char2keychord 'u' = return $ (,) [] UKey+char2keychord 'U' = return $ (,) [ShiftModifier] UKey+char2keychord 'v' = return $ (,) [] VKey+char2keychord 'V' = return $ (,) [ShiftModifier] VKey+char2keychord 'w' = return $ (,) [] WKey+char2keychord 'W' = return $ (,) [ShiftModifier] WKey+char2keychord 'x' = return $ (,) [] XKey+char2keychord 'X' = return $ (,) [ShiftModifier] XKey+char2keychord 'y' = return $ (,) [] YKey+char2keychord 'Y' = return $ (,) [ShiftModifier] YKey+char2keychord 'z' = return $ (,) [] ZKey+char2keychord 'Z' = return $ (,) [ShiftModifier] ZKey++char2keychord '0' = return $ (,) [] ZeroKey+char2keychord ')' = return $ (,) [ShiftModifier] ZeroKey+char2keychord '1' = return $ (,) [] OneKey+char2keychord '!' = return $ (,) [ShiftModifier] OneKey+char2keychord '2' = return $ (,) [] TwoKey+char2keychord '@' = return $ (,) [ShiftModifier] TwoKey+char2keychord '3' = return $ (,) [] ThreeKey+char2keychord '#' = return $ (,) [ShiftModifier] ThreeKey+char2keychord '4' = return $ (,) [] FourKey+char2keychord '$' = return $ (,) [ShiftModifier] FourKey+char2keychord '5' = return $ (,) [] FiveKey+char2keychord '%' = return $ (,) [ShiftModifier] FiveKey+char2keychord '6' = return $ (,) [] SixKey+char2keychord '^' = return $ (,) [ShiftModifier] SixKey+char2keychord '7' = return $ (,) [] SevenKey+char2keychord '&' = return $ (,) [ShiftModifier] SevenKey+char2keychord '8' = return $ (,) [] EightKey+char2keychord '*' = return $ (,) [ShiftModifier] EightKey+char2keychord '9' = return $ (,) [] NineKey+char2keychord '(' = return $ (,) [ShiftModifier] NineKey++char2keychord '`' = return $ (,) [] GraveKey+char2keychord '~' = return $ (,) [ShiftModifier] GraveKey+char2keychord '-' = return $ (,) [] MinusKey+char2keychord '_' = return $ (,) [ShiftModifier] MinusKey+char2keychord '=' = return $ (,) [] EqualKey+char2keychord '+' = return $ (,) [ShiftModifier] EqualKey+char2keychord '[' = return $ (,) [] LeftBracketKey+char2keychord '{' = return $ (,) [ShiftModifier] LeftBracketKey+char2keychord ']' = return $ (,) [] RightBracketKey+char2keychord '}' = return $ (,) [ShiftModifier] RightBracketKey+char2keychord '\\' = return $ (,) [] BackslashKey+char2keychord '|' = return $ (,) [ShiftModifier] BackslashKey+char2keychord ';' = return $ (,) [] SemicolonKey+char2keychord ':' = return $ (,) [ShiftModifier] SemicolonKey+char2keychord '\'' = return $ (,) [] QuoteKey+char2keychord '"' = return $ (,) [ShiftModifier] QuoteKey+char2keychord ',' = return $ (,) [] CommaKey+char2keychord '<' = return $ (,) [ShiftModifier] CommaKey+char2keychord '.' = return $ (,) [] PeriodKey+char2keychord '>' = return $ (,) [ShiftModifier] PeriodKey+char2keychord '/' = return $ (,) [] SlashKey+char2keychord '?' = return $ (,) [ShiftModifier] SlashKey++char2keychord ' ' = return $ (,) [] SpaceKey+char2keychord '\t' = return $ (,) [] TabKey+char2keychord '\n' = return $ (,) [] ReturnKey++char2keychord c = failed $+ "char2keychord: un-pressable Char: " ++ show c+++{- | the character that represents the keychord:++>>> keychord2char ([ShiftModifier], TwoKey) :: Maybe Char+Just '@'++some keychordes cannot be represented as characters, like keyboard shortcuts:++>>> keychord2char ([Command], CKey) :: Maybe Char+Nothing++>>> import Data.Char+>>> import Data.Maybe+prop> maybe True isAscii (keychord2char k)+TODO replace true with redo test++-}+keychord2char :: (MonadThrow m) => KeyChord -> m Char++keychord2char (KeyChord [] AKey) = return 'a'+keychord2char (KeyChord [ShiftModifier] AKey) = return 'A'+keychord2char (KeyChord [] BKey) = return 'b'+keychord2char (KeyChord [ShiftModifier] BKey) = return 'B'+keychord2char (KeyChord [] CKey) = return 'c'+keychord2char (KeyChord [ShiftModifier] CKey) = return 'C'+keychord2char (KeyChord [] DKey) = return 'd'+keychord2char (KeyChord [ShiftModifier] DKey) = return 'D'+keychord2char (KeyChord [] EKey) = return 'e'+keychord2char (KeyChord [ShiftModifier] EKey) = return 'E'+keychord2char (KeyChord [] FKey) = return 'f'+keychord2char (KeyChord [ShiftModifier] FKey) = return 'F'+keychord2char (KeyChord [] GKey) = return 'g'+keychord2char (KeyChord [ShiftModifier] GKey) = return 'G'+keychord2char (KeyChord [] HKey) = return 'h'+keychord2char (KeyChord [ShiftModifier] HKey) = return 'H'+keychord2char (KeyChord [] IKey) = return 'i'+keychord2char (KeyChord [ShiftModifier] IKey) = return 'I'+keychord2char (KeyChord [] JKey) = return 'j'+keychord2char (KeyChord [ShiftModifier] JKey) = return 'J'+keychord2char (KeyChord [] KKey) = return 'k'+keychord2char (KeyChord [ShiftModifier] KKey) = return 'K'+keychord2char (KeyChord [] LKey) = return 'l'+keychord2char (KeyChord [ShiftModifier] LKey) = return 'L'+keychord2char (KeyChord [] MKey) = return 'm'+keychord2char (KeyChord [ShiftModifier] MKey) = return 'M'+keychord2char (KeyChord [] NKey) = return 'n'+keychord2char (KeyChord [ShiftModifier] NKey) = return 'N'+keychord2char (KeyChord [] OKey) = return 'o'+keychord2char (KeyChord [ShiftModifier] OKey) = return 'O'+keychord2char (KeyChord [] PKey) = return 'p'+keychord2char (KeyChord [ShiftModifier] PKey) = return 'P'+keychord2char (KeyChord [] QKey) = return 'q'+keychord2char (KeyChord [ShiftModifier] QKey) = return 'Q'+keychord2char (KeyChord [] RKey) = return 'r'+keychord2char (KeyChord [ShiftModifier] RKey) = return 'R'+keychord2char (KeyChord [] SKey) = return 's'+keychord2char (KeyChord [ShiftModifier] SKey) = return 'S'+keychord2char (KeyChord [] TKey) = return 't'+keychord2char (KeyChord [ShiftModifier] TKey) = return 'T'+keychord2char (KeyChord [] UKey) = return 'u'+keychord2char (KeyChord [ShiftModifier] UKey) = return 'U'+keychord2char (KeyChord [] VKey) = return 'v'+keychord2char (KeyChord [ShiftModifier] VKey) = return 'V'+keychord2char (KeyChord [] WKey) = return 'w'+keychord2char (KeyChord [ShiftModifier] WKey) = return 'W'+keychord2char (KeyChord [] XKey) = return 'x'+keychord2char (KeyChord [ShiftModifier] XKey) = return 'X'+keychord2char (KeyChord [] YKey) = return 'y'+keychord2char (KeyChord [ShiftModifier] YKey) = return 'Y'+keychord2char (KeyChord [] ZKey) = return 'z'+keychord2char (KeyChord [ShiftModifier] ZKey) = return 'Z'++keychord2char (KeyChord [] ZeroKey) = return '0'+keychord2char (KeyChord [ShiftModifier] ZeroKey) = return ')'+keychord2char (KeyChord [] OneKey) = return '1'+keychord2char (KeyChord [ShiftModifier] OneKey) = return '!'+keychord2char (KeyChord [] TwoKey) = return '2'+keychord2char (KeyChord [ShiftModifier] TwoKey) = return '@'+keychord2char (KeyChord [] ThreeKey) = return '3'+keychord2char (KeyChord [ShiftModifier] ThreeKey) = return '#'+keychord2char (KeyChord [] FourKey) = return '4'+keychord2char (KeyChord [ShiftModifier] FourKey) = return '$'+keychord2char (KeyChord [] FiveKey) = return '5'+keychord2char (KeyChord [ShiftModifier] FiveKey) = return '%'+keychord2char (KeyChord [] SixKey) = return '6'+keychord2char (KeyChord [ShiftModifier] SixKey) = return '^'+keychord2char (KeyChord [] SevenKey) = return '7'+keychord2char (KeyChord [ShiftModifier] SevenKey) = return '&'+keychord2char (KeyChord [] EightKey) = return '8'+keychord2char (KeyChord [ShiftModifier] EightKey) = return '*'+keychord2char (KeyChord [] NineKey) = return '9'+keychord2char (KeyChord [ShiftModifier] NineKey) = return '('++keychord2char (KeyChord [] GraveKey) = return '`'+keychord2char (KeyChord [ShiftModifier] GraveKey) = return '~'+keychord2char (KeyChord [] MinusKey) = return '-'+keychord2char (KeyChord [ShiftModifier] MinusKey) = return '_'+keychord2char (KeyChord [] EqualKey) = return '='+keychord2char (KeyChord [ShiftModifier] EqualKey) = return '+'+keychord2char (KeyChord [] LeftBracketKey) = return '['+keychord2char (KeyChord [ShiftModifier] LeftBracketKey) = return '{'+keychord2char (KeyChord [] RightBracketKey) = return ']'+keychord2char (KeyChord [ShiftModifier] RightBracketKey) = return '}'+keychord2char (KeyChord [] BackslashKey) = return '\\'+keychord2char (KeyChord [ShiftModifier] BackslashKey) = return '|'+keychord2char (KeyChord [] SemicolonKey) = return ';'+keychord2char (KeyChord [ShiftModifier] SemicolonKey) = return ':'+keychord2char (KeyChord [] QuoteKey) = return '\''+keychord2char (KeyChord [ShiftModifier] QuoteKey) = return '"'+keychord2char (KeyChord [] CommaKey) = return ','+keychord2char (KeyChord [ShiftModifier] CommaKey) = return '<'+keychord2char (KeyChord [] PeriodKey) = return '.'+keychord2char (KeyChord [ShiftModifier] PeriodKey) = return '>'+keychord2char (KeyChord [] SlashKey) = return '/'+keychord2char (KeyChord [ShiftModifier] SlashKey) = return '?'++keychord2char (KeyChord [] SpaceKey) = return ' '+keychord2char (KeyChord [] TabKey) = return '\t'+keychord2char (KeyChord [] ReturnKey) = return '\n'++keychord2char k = failed $+ "keychord2char: non-unicode-representable keychord: " ++ show k++-- TODO partial isomorphism between char2keychord and keychord2char?
+ sources/Workflow/Pure/Execute.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE LambdaCase, ScopedTypeVariables #-}+module Workflow.Pure.Execute where+import Workflow.Types++import Control.Monad.Free+-- import Control.Monad.Trans.Free hiding (Pure, Free, iterM) -- TODO++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 ((&))+++{-| downcasts a monad to a list of functors.++e.g.++>>> isSimpleWorkflow $ getClipboard >>= sendText+Nothing++>>> isSimpleWorkflow $ setClipboard "copying..." >> sendKeyChord [HyperModifier] CKey+Just [SetClipboard "copying..." (),SendKeyChord [HyperModifier] CKey ()]++TODO When 'Just':++@+'isSimpleWorkflow' >>> fromJust >>> 'fromWorkflow_' === 'id'+@++-}+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++ -- simple+ 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++ -- complex+ GetClipboard _ -> mzero+ CurrentApplication _ -> mzero++type SimpleWorkflowM = WriterT [Workflow_] (MaybeT Identity)++{- | shows (an inaccurate approximation of) the+"static" data flow of some 'Workflow',+by showing its primitive operations (in @do-notation@).++e.g.++>>> :{+putStrLn . showWorkflow $ do+ sendKeyChord [Command, Shift] BKey+ delay 1000+ sendKeyChord [Command] DownArrowKey+ x1 <- currentApplication+ x2 <- getClipboard+ openURL $ "https://www.google.com/search?q=" <> x2+ setClipboard x1+ getClipboard+:}+do+ sendKeyChord ([Command,Shift]) (BKey)+ delay (1000)+ sendKeyChord ([Command]) (DownArrowKey)+ x1 <- currentApplication+ x2 <- getClipboard+ openURL ("https://www.google.com/search?q={x2}")+ setClipboard ("{x1}")+ x3 <- getClipboard+ return "{x3}"++(note: doesn't print variables as raw strings (cf. 'print' versus 'putStrLn'), as it doesn't "crystallize" all operations into "symbols", but gives you an idea of the data flow. however, it does correctly track the control flow, even when the variables are used non-sequentially.)++(note: the variables in the code were named to be consistent with+'gensym', for readability. but of course the bindings aren't reified,+and they could have been named anything)++basically, the monadically-bound variable @x1@ is shown as if it were literally @"{x1}"@ (rather than, the current clipboard contents). a more complicated alternative could be to purely model the state: e.g. a clipboard, with 'SetClipboard' and 'GetClipboard' working together, etc.).++TODO would be complicated by SendTextTo; unless unit consuctors are+distinguished (as sendTextTo =<< currentApplication is kinda Applicative).++-}+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+ -- TODO SendMouseClick flags n b k -> ((" sendMouseClick " <> showArgs [show flags, show n, show b]) <>) <$> 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++ -- TODO distinguish between strings and variables to avoid:+ -- x2 <- getClipboard+ -- sendText ("x2")++ 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++{-++ \case++ SendKeyChord flags key k -> k+ SendText s k -> k+ SendMouseClick flags n button k -> k+ SendMouseScroll flags scroll n k -> k+ SetClipboard s k -> k+ OpenApplication app k -> k+ OpenURL url k -> k+ Delay t k -> k++ GetClipboard f -> f+ CurrentApplication f -> f++-}
+ sources/Workflow/Pure/Extra.hs view
@@ -0,0 +1,30 @@+module Workflow.Pure.Extra+ ( module Workflow.Pure.Extra++ , module Control.DeepSeq+ , module Data.Semigroup+ , module Control.Monad.Catch++ , module GHC.Generics+ , module Data.Data+ , module Control.Arrow++ , module Data.Function+ ) where++import Control.DeepSeq (NFData)+import Data.Semigroup (Semigroup)+import Control.Monad.Catch (MonadThrow(..))++import GHC.Generics (Generic)+import Data.Data (Data)+import Control.Arrow ((>>>))++import Data.Function ((&))+++nothing :: (Monad m) => m ()+nothing = return ()++failed :: (MonadThrow m) => String -> m a+failed = throwM . userError
+ sources/Workflow/Pure/Main.hs view
@@ -0,0 +1,16 @@+module Workflow.Pure.Main where+import Workflow.Pure+import Workflow.Core++{-+stack build && stack exec -- workflow-pure-example+-}+main :: IO ()+main = do+ putStrLn "\nWorkflow.Pure...\n"++ -- Workflow_ fixes {No instance for (Show (WorkflowF ()))}+ print $ isSimpleWorkflow $ getClipboard >>= sendText+ -- Nothing+ print $ isSimpleWorkflow $ setClipboard "copying..." >> sendKeyChord [HyperModifier] CKey+ -- Just [SetClipboard "copying..." (),SendKeyChord [HyperModifier] CKey ()]
+ sources/Workflow/Pure/Types.hs view
@@ -0,0 +1,1 @@+module Workflow.Pure.Types where
+ stack.yaml view
@@ -0,0 +1,15 @@+resolver: lts-8.12+compiler: ghc-8.0.2++nix:+ # enable: true+ pure: true+ packages: []++packages:+- .+- ../workflow-types++extra-deps:+- workflow-types-0.0.0+- spiros-0.0.0
+ tests/DocTest.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+import Test.DocTest++main = doctest+ [ "sources/Workflow/Pure.hs"+ ]+
+ tests/UnitTest.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+
+ tests/Workflow/Pure/Test.hs view
@@ -0,0 +1,5 @@+module Workflow.Pure.Test where+import Workflow.Pure++main = do+ print "Workflow.Pure"
+ workflow-pure.cabal view
@@ -0,0 +1,147 @@+name: workflow-pure+version: 0.0.0+synopsis: TODO+description: TODO+homepage: http://github.com/sboosali/workflow-pure#readme+license: BSD3+license-file: LICENSE+author: Spiros Boosalis+maintainer: samboosalis@gmail.com+copyright: 2016 Spiros Boosalis+category: TODO+build-type: Simple+cabal-version: >=1.10++-- PVP+-- https://wiki.haskell.org/Package_versioning_policy+-- "A.B is known as the major version number, and C the minor version number."++extra-source-files:+ README.md+ .gitignore+ .travis.yml+ HLint.hs+ stack.yaml++--data-files:++-- data/++source-repository head+ type: git+ location: https://github.com/sboosali/workflow-pure+++library+ hs-source-dirs: sources+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-unticked-promoted-constructors+-- default-extensions:++ exposed-modules:+ Workflow.Pure+ Workflow.Pure.Types+ Workflow.Pure.Execute+ Workflow.Pure.Char++-- other-modules:+ Workflow.Pure.Extra+ Workflow.Pure.Main++ build-depends:+ base >=4.7 && <5+ , workflow-types ==0.0.0++ , transformers+ , mtl+ -- , containers+ -- , bytestring+ -- , stm+ -- , template-haskell++ , deepseq+ , semigroups+ -- ,+ -- , lens+ , exceptions+ , free+ -- , bifunctors+ -- , profunctors+ -- , either+ -- , pipes+ -- , formatting+ -- , servant+ -- , Earley+ -- , split+ -- , interpolatedstring-perl6+ -- , wl-pprint-text+ -- , text+ -- , aeson+ -- , hashable+ -- , unordered-containers+ -- , async+ -- , parallel+++executable example-workflow-pure+ hs-source-dirs: executables+ main-is: Main.hs++ default-language: Haskell2010+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N++ build-depends:+ base+ , workflow-pure+++-- $ stack test doctest+test-suite doctest+ hs-source-dirs: tests+ main-is: DocTest.hs+ type: exitcode-stdio-1.0++ default-language: Haskell2010+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N++ build-depends:+ base+ , workflow-pure+ , doctest+++-- $ stack test unittest+test-suite unittest+ hs-source-dirs: tests+ main-is: UnitTest.hs+ type: exitcode-stdio-1.0++ default-language: Haskell2010+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N++ other-modules:+ Workflow.Pure.Test++ build-depends:+ base+ , workflow-pure+ , hspec ==2.2.*+ , QuickCheck ==2.8.*+ -- , tasty+ -- , tasty-quickcheck+++-- $ stack bench+benchmark command+ hs-source-dirs: benchmarks+ main-is: Bench.hs+ type: exitcode-stdio-1.0++ default-language: Haskell2010+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N++ build-depends:+ base+ , workflow-pure+ , criterion+ , deepseq