mvc 1.0.3 → 1.0.4

raw patch · 3 files changed

+39/−23 lines, 3 filesdep +foldldep ~contravariantdep ~pipes-concurrency

Dependencies added: foldl

Dependency ranges changed: contravariant, pipes-concurrency

Files

• mvc.cabal +4/−3
• src/MVC.hs +31/−17
• src/MVC/Prelude.hs +4/−3

@@ -1,5 +1,5 @@ Name: mvc
-Version: 1.0.3
+Version: 1.0.4
 Cabal-Version: >=1.8.0.2
 Build-Type: Simple
 License: BSD3
@@ -28,11 +28,12 @@     Build-Depends:
         base              >= 4       && < 5  ,
         async             >= 2.0.0   && < 2.1,
-        contravariant                   < 1.3,
+        contravariant                   < 1.4,
+        foldl                           < 1.1,
         managed                         < 1.1,
         mmorph            >= 1.0.2   && < 1.1,
         pipes             >= 4.1.0   && < 4.2,
-        pipes-concurrency >= 2.0.1   && < 2.1,
+        pipes-concurrency >= 2.0.3   && < 2.1,
         transformers      >= 0.2.0.0 && < 0.5.0.0
     Exposed-Modules:
         MVC,

@@ -73,6 +73,7 @@     -- $view
     , View
     , asSink
+    , asFold
     , handles
 
     -- * Models
@@ -102,7 +103,9 @@     , module Pipes.Concurrent
     ) where
 
+import Control.Applicative (Applicative)
 import Control.Category (Category(..))
+import Control.Foldl (FoldM(..), impurely, premapM, pretraverseM)
 import Control.Monad.Managed (Managed, managed, with)
 import Control.Monad.Morph (generalize)
 import Control.Monad.Trans.State.Strict (State, execStateT)
@@ -112,6 +115,7 @@ import qualified Data.Monoid as M
 import Pipes
 import Pipes.Concurrent
+import Pipes.Prelude (foldM)
 
 import Prelude hiding ((.), id)
 
@@ -245,21 +249,33 @@ >
 > contramap f mempty = mempty
 -}
-newtype View a = AsSink (a -> IO ())
+newtype View a = AsFold (FoldM IO a ())
 
 instance Monoid (View a) where
-    mempty = AsSink (\_ -> return ())
-    mappend (AsSink write1) (AsSink write2) =
-        AsSink (\a -> write1 a >> write2 a)
+    mempty = AsFold mempty
+    mappend (AsFold fold1) (AsFold fold2) = AsFold (mempty fold1 fold2)
 
 instance Contravariant View where
-    contramap f (AsSink k) = AsSink (k . f)
+    contramap f (AsFold fold) = AsFold (premapM f fold)
 
 -- | Create a `View` from a sink
 asSink :: (a -> IO ()) -> View a
-asSink = AsSink 
+asSink sink = AsFold (FoldM step begin done)
+  where
+    step x a = do
+        sink a
+        return x
+    begin = return ()
+    done = return
 {-# INLINABLE asSink #-}
 
+-- | Create a `View` from a `FoldM`
+asFold :: FoldM IO a () -> View a
+asFold = AsFold
+{-# INLINABLE asFold #-}
+
+type Traversal' a b = forall f . Applicative f => (b -> f b) -> a -> f a
+
 {-| Think of the type as one of the following types:
 
 > handles :: Prism'     a b -> View b -> View a
@@ -277,16 +293,12 @@ > handles p mempty = mempty
 -}
 handles
-    :: ((b -> Constant (First b) b) -> (a -> Constant (First b) a))
+    :: Traversal' a b
     -- ^
     -> View b
     -- ^
     -> View a
-handles k (AsSink send_) = AsSink (\a -> case match a of
-    Nothing -> return ()
-    Just b  -> send_ b )
-  where
-    match = M.getFirst . getConstant . k (Constant . M.First . Just)
+handles k (AsFold fold) = AsFold (pretraverseM k fold)
 {-# INLINABLE handles #-}
 
 {- $model
@@ -353,11 +365,13 @@     -> IO s
     -- ^ Returns final state
 runMVC initialState (AsPipe pipe) viewController =
-    with viewController $ \(AsSink sink, AsInput input) ->
-    flip execStateT initialState $ runEffect $
-            fromInput input
-        >-> hoist (hoist generalize) pipe
-        >-> for cat (liftIO . sink)
+    with viewController $ \(AsFold (FoldM step begin done), AsInput input) -> do
+    let step' x a = lift (step x a)
+    let begin'    = lift begin
+    let done'  x  = lift (done x)
+    let fold' = FoldM step' begin' done'
+    flip execStateT initialState $
+        impurely foldM fold' (fromInput input >-> hoist (hoist generalize) pipe)
 {-# INLINABLE runMVC #-}
 
 {- $managed

@@ -50,14 +50,14 @@ 
 -- | Read lines from standard input
 stdinLines :: Managed (Controller String)
-stdinLines = producer Single Pipes.stdinLn
+stdinLines = producer (bounded 1) Pipes.stdinLn
 {-# INLINABLE stdinLines #-}
 
 -- | Read lines from a file
 inLines :: FilePath -> Managed (Controller String)
 inLines filePath = do
     handle <- inHandle filePath
-    producer Single (Pipes.fromHandle handle)
+    producer (bounded 1) (Pipes.fromHandle handle)
 {-# INLINABLE inLines #-}
 
 -- | 'read' values from a file, one value per line, skipping failed parses
@@ -71,7 +71,8 @@ 
 -- | Emit empty values spaced by a delay in seconds
 tick :: Double -> Managed (Controller ())
-tick n = producer Single $ lift (threadDelay (truncate (n * 1000000))) >~ cat
+tick n = producer (bounded 1) $
+    lift (threadDelay (truncate (n * 1000000))) >~ cat
 {-# INLINABLE tick #-}
 
 -- | Create a `View` from a `Consumer`