operational-extra 0.3 → 0.4

raw patch · 5 files changed

+35/−5 lines, 5 files

Files

• operational-extra.cabal +2/−1
• src/Control/Monad/Operational/Console.hs +11/−0
• src/Control/Monad/Operational/Console/Text.hs +16/−0
• src/Control/Monad/Operational/Interpret.hs +2/−1
• src/Control/Monad/Operational/Now.hs +4/−3

@@ -1,5 +1,5 @@ name:                operational-extra-version:             0.3+version:             0.4 synopsis:            Interpretation functions and simple instruction sets for operational description:         Please see README.md homepage:            http://github.com/andrewthad/vinyl-ecosystem@@ -19,6 +19,7 @@                        Control.Monad.Operational.Exception                        Control.Monad.Operational.Now                        Control.Monad.Operational.Console+                       Control.Monad.Operational.Console.Text   build-depends:       base >= 4.7 && < 5                      , operational  >= 0.2.3.2                      , time         >= 1.4

@@ -20,6 +20,17 @@ put :: content -> ProgramT (ConsoleI content) m () put = singleton . PutI +getRetry :: Monad m => (content -> content) -> (content -> Maybe a) -> ProgramT (ConsoleI content) m a+getRetry = go +  where +  go failureMessage parse = do+    content <- get+    case parse content of+      Nothing -> do+        put (failureMessage content)+        go failureMessage parse+      Just a -> return a+ interpretConsoleStringIO :: ConsoleI String a -> IO a interpretConsoleStringIO instr = case instr of   PutI content -> putStrLn content

@@ -0,0 +1,16 @@+module Control.Monad.Operational.Console.Text where++import           Control.Monad.Operational (ProgramT)+import           Control.Monad.Operational.Console (ConsoleI(..))+import           Data.Text (Text)+import qualified Control.Monad.Operational.Console as Console++get :: ProgramT (ConsoleI Text) m Text+get = Console.get++put :: Text -> ProgramT (ConsoleI Text) m ()+put = Console.put++getRetry :: Monad m => (Text -> Text) -> (Text -> Maybe a) -> ProgramT (ConsoleI Text) m a+getRetry = Console.getRetry+

@@ -5,7 +5,8 @@ import           Control.Monad.Operational import           Control.Monad.Trans.Class -data Around m instr = Around (forall a. instr a -> (m (), a -> m ()))+data Around     m instr = Around     { getAround :: forall a. instr a -> (m (), a -> m ()) }+data ApplyInstr m instr = ApplyInstr { getApplyInstr :: forall a. instr a -> m a }  instance Applicative m => Monoid (Around m instr) where   mempty = Around (\_ -> (pure (), \_ -> pure ()))

@@ -1,6 +1,7 @@ module Control.Monad.Operational.Now where  import           Control.Monad.Operational+import           Control.Monad.Operational.Interpret import           Data.IORef                (IORef, newIORef, readIORef,                                             writeIORef) import           Data.Time                 (NominalDiffTime, UTCTime,@@ -12,13 +13,13 @@ interpretNow :: NowI a -> IO a interpretNow NowI = getCurrentTime -interpretNowMoving :: UTCTime -> NominalDiffTime -> IO (NowI a -> IO a)+interpretNowMoving :: UTCTime -> NominalDiffTime -> IO (ApplyInstr IO NowI) interpretNowMoving start interval = do   timeRef <- newIORef start   return (interpretNowMoving' timeRef interval) -interpretNowMoving' :: IORef UTCTime -> NominalDiffTime -> NowI a -> IO a-interpretNowMoving' timeRef interval NowI = do+interpretNowMoving' :: IORef UTCTime -> NominalDiffTime -> ApplyInstr IO NowI+interpretNowMoving' timeRef interval = ApplyInstr $ \NowI -> do   time <- readIORef timeRef   writeIORef timeRef (addUTCTime interval time)   return time