pipes-category 0.1.0.0 → 0.2.0.0

raw patch · 5 files changed

+208/−208 lines, 5 filesdep +hspecdep ~basedep ~pipesdep ~pipes-categoryPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec

Dependency ranges changed: base, pipes, pipes-category, transformers

API changes (from Hackage documentation)

Files

• app/Main.hs +0/−91
• pipes-category.cabal +8/−15
• src/Pipes/PipeC.hs +0/−101
• src/Pipes/Shaft.hs +101/−0
• test/Spec.hs +99/−1

@@ -1,91 +0,0 @@-module Main where--import Control.Monad-import Control.Monad.Trans.Class-import qualified Pipes as P-import qualified Pipes.Prelude as PP-import qualified Pipes.PipeC as PPC-import Control.Arrow--sig1 :: Monad m => P.Producer Int m ()-sig1 = do-  P.yield 1-  P.yield 2-  P.yield 3-  P.yield 4-  P.yield 5-  P.yield 6-  P.yield 7-  P.yield 8-  P.yield 9--sig2 :: Monad m => P.Producer (Either Int String) m ()-sig2 = do-  P.yield $ Left 1-  P.yield $ Right "a"-  P.yield $ Left 2-  P.yield $ Right "b"-  P.yield $ Left 3-  P.yield $ Right "c"-  P.yield $ Left 4-  P.yield $ Right "d"-  P.yield $ Left 5-  P.yield $ Right "e"--sigConsumer :: Show a => P.Consumer a IO ()-sigConsumer = forever $ do-  a <- P.await-  lift $ print a--main :: IO ()-main = do-  putStrLn "\nOriginal"-  P.runEffect $ sig1 P.>-> sigConsumer--  putStrLn "\nfirst"-  P.runEffect $ sig1-    P.>-> PP.map (\a -> (a, a))-    P.>-> (PPC.getPipeC $ first $ PPC.PipeC (PP.map (+ 10)))-    -- P.>-> (_Unwrapping PPC.PipeC %~ first $ PP.map (+ 10))-    P.>-> sigConsumer--  putStrLn "\nsecond"-  P.runEffect $ sig1-    P.>-> PP.map (\a -> (a, a))-    P.>-> (PPC.getPipeC $ second $ PPC.PipeC (PP.map (+ 10)))-    -- P.>-> (_Unwrapping PPC.PipeC %~ second $ PP.map (+ 10))-    P.>-> sigConsumer--  putStrLn "\n***"-  P.runEffect $ sig1-    P.>-> PP.map (\a -> (a, a))-    P.>-> (PPC.getPipeC $ PPC.PipeC (PP.map (+ 10)) *** PPC.PipeC (PP.map (+ 20)))-    P.>-> sigConsumer--  putStrLn "\n&&&"-  P.runEffect $ sig1-    P.>-> (PPC.getPipeC $ PPC.PipeC (PP.map (+ 10)) &&& PPC.PipeC (PP.map (+ 20)))-    P.>-> sigConsumer--  putStrLn "\nOriginal2"-  P.runEffect $ sig2 P.>-> sigConsumer--  putStrLn "\nleft"-  P.runEffect $ sig2-    P.>-> (PPC.getPipeC $ left $ PPC.PipeC (PP.map (+ 10)))-    P.>-> sigConsumer--  putStrLn "\nright"-  P.runEffect $ sig2-    P.>-> (PPC.getPipeC $ right $ PPC.PipeC (PP.map (++ "!")))-    P.>-> sigConsumer--  putStrLn "\n+++"-  P.runEffect $ sig2-    P.>-> (PPC.getPipeC $ PPC.PipeC (PP.map (+ 10)) +++ PPC.PipeC (PP.map (++ "!")))-    P.>-> sigConsumer--  putStrLn "\n|||"-  P.runEffect $ sig2-    P.>-> (PPC.getPipeC $ PPC.PipeC (PP.map (show . (+ 10))) ||| PPC.PipeC (PP.map (++ "!")))-    P.>-> sigConsumer

@@ -1,5 +1,5 @@ name:                pipes-category-version:             0.1.0.0+version:             0.2.0.0 synopsis:            Allows instances for Category, Arrow and ArrowChoice for Pipes. description:         Please see README.md homepage:            https://github.com/louispan/pipes-category#readme@@ -15,8 +15,8 @@  library   hs-source-dirs:      src-  exposed-modules:     Pipes.PipeC-  build-depends:       base < 6+  exposed-modules:     Pipes.Shaft+  build-depends:       base >= 4.7 && < 5                      , lens >= 4 && < 5                      , mtl >= 2 && < 3                      , pipes >= 4 && < 5@@ -24,22 +24,15 @@   ghc-options:         -Wall   default-language:    Haskell2010 -executable pipes-category-exe-  hs-source-dirs:      app-  main-is:             Main.hs-  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N-  build-depends:       base-                     , pipes-                     , pipes-category-                     , transformers-  default-language:    Haskell2010- test-suite pipes-category-test   type:                exitcode-stdio-1.0   hs-source-dirs:      test   main-is:             Spec.hs-  build-depends:       base-                     , pipes-category+  build-depends:       base >= 4.7 && < 5+                     , pipes >= 4 && < 5+                     , pipes-category >= 0.1.0.0+                     , transformers >= 0.4 && < 0.6+                     , hspec >= 2 && < 3   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010 

@@ -1,101 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}---- | Allows instances for Category, Arrow and ArrowChoice for 'Pipes.Pipe' using newtypewrapper 'PipeC'.-module Pipes.PipeC (PipeC(..)) where--import Control.Arrow-import Control.Category-import Control.Lens-import Control.Monad-import Control.Monad.State.Strict-import Data.Tuple-import qualified Pipes as P-import qualified Pipes.Extras as PE-import qualified Pipes.Lift as PL-import qualified Pipes.Prelude as PP--newtype PipeC m r b c = PipeC { getPipeC :: P.Pipe b c m r }--makeWrapped ''PipeC--instance Monad m => Category (PipeC m r) where-  id = PipeC P.cat-  (PipeC a) . (PipeC b) = PipeC (b P.>-> a)--instance Monad m => Arrow (PipeC m r) where-  arr f = PipeC (PE.arr f)--  -- | Send the first component of the input through the argument arrow, and copy the rest unchanged to the output.-  -- first :: Monad m => PipeC m r b c -> PipeC m r (b, d) (c, d)-  first (PipeC bc) = PipeC $ PL.evalStateP Nothing go -- State :: Maybe d-   -- Not reusing (***) as this requires a simpler state-   where--    justd (_, d) = Just d--    go = store' justd -- store (Just d)-      P.>-> PP.map fst -- get b from (b, d)-      P.>-> P.hoist lift bc -- make original pipe bc stateful-      P.>-> outcd--    outcd = forever $ do-      c <- P.await -- c from output of pipe bc-      s <- get -- (Just d) from storage-      case s of-        Just d -> P.yield (c, d)-        Nothing -> pure () -- shouldn't happen--    -- | Store the output of the pipe into a MonadState.-    store' :: MonadState s m => (a -> s) -> P.Pipe a a m r-    store' f = forever $ do-      a <- P.await-      put $ f a-      P.yield a--  -- | A mirror image of 'first'.-  -- second :: Monad m => PipeC m r b c -> PipeC m r (d, b) (d, c)-  -- Don't use *** as an optimization, as it will require running first twice.-  second (PipeC bc) = PipeC $ PP.map swap-    P.>-> getPipeC (first $ PipeC bc)-    -- P.>->  (_Unwrapping PipeC %~ first $ bc)-    P.>-> PP.map swap--  -- Note: The following works, but may not actually be more optimal than default (***)-  -- So maybe it's better to reduce the amount of code to maintain.-  -- -- |Split the input between the two argument pipes and combine their output.-  -- -- (***) :: Monad m => PipeC m r b c -> PipeC m r b' c' -> PipeC m r (b, b') (c, c')-  -- (PipeC bc) *** (PipeC bc') = PipeC $ PL.evalStateP Nothing go -- State :: Maybe (Either c b')-  --  where-  --   justb' (_, b') = Just (Right b')--  --   -- store (Just (Left c)), and yields b'-  --   storec = forever $ do-  --     c <- P.await -- c from output of pipe bc-  --     s <- get -- Just (Right b') from storage-  --     put $ Just (Left c) -- store (Just (Left c))-  --     case s of-  --       Just (Right b') -> P.yield b'-  --       _ -> pure () -- shouldn't happen--  --   -- get (Just (Left c)) from stroage, and combine with awaited c'-  --   outcc' = forever $ do-  --     c' <- P.await -- c' from output of pipe bc'-  --     s <- get -- Just (Left c) from storage-  --     case s of-  --       Just (Left c) -> P.yield (c, c')-  --       _ -> pure () -- shouldn't happen--  --   go = store' justb' -- store (Just (Right b'))-  --     P.>-> PP.map fst -- get b from (b, b')-  --     P.>-> P.hoist lift bc -- make original pipe bc stateful-  --     P.>-> storec -- store (Just (Left c)), and yields b'-  --     P.>-> P.hoist lift bc' -- make original pipe bc' stateful-  --     P.>-> outcc'--instance Monad m => ArrowChoice (PipeC m r) where-  left (PipeC a) = PipeC (PE.left a)-  right (PipeC a) = PipeC (PE.right a)-  (PipeC a) +++ (PipeC b) = PipeC (a PE.+++ b)

@@ -0,0 +1,101 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-- | Allows instances for Category, Arrow and ArrowChoice for 'Pipes.Pipe' using newtype wrapper 'Shaft'.+module Pipes.Shaft (Shaft(..)) where++import Control.Arrow+import Control.Category+import Control.Lens+import Control.Monad+import Control.Monad.State.Strict+import Data.Tuple+import qualified Pipes as P+import qualified Pipes.Extras as PE+import qualified Pipes.Lift as PL+import qualified Pipes.Prelude as PP++newtype Shaft r m b c = Shaft { runShaft :: P.Pipe b c m r }++makeWrapped ''Shaft++instance Monad m => Category (Shaft r m) where+  id = Shaft P.cat+  (Shaft a) . (Shaft b) = Shaft (b P.>-> a)++instance Monad m => Arrow (Shaft r m) where+  arr f = Shaft (PE.arr f)++  -- | Send the first component of the input through the argument arrow, and copy the rest unchanged to the output.+  -- first :: Monad m => Shaft r m b c -> Shaft r m (b, d) (c, d)+  first (Shaft bc) = Shaft $ PL.evalStateP Nothing go -- State :: Maybe d+   -- Not reusing (***) as this requires a simpler state+   where++    justd (_, d) = Just d++    go = store' justd -- store (Just d)+      P.>-> PP.map fst -- get b from (b, d)+      P.>-> P.hoist lift bc -- make original pipe bc stateful+      P.>-> outcd++    outcd = forever $ do+      c <- P.await -- c from output of pipe bc+      s <- get -- (Just d) from storage+      case s of+        Just d -> P.yield (c, d)+        Nothing -> pure () -- shouldn't happen++    -- | Store the output of the pipe into a MonadState.+    store' :: MonadState s m => (a -> s) -> P.Pipe a a m r+    store' f = forever $ do+      a <- P.await+      put $ f a+      P.yield a++  -- | A mirror image of 'first'.+  -- second :: Monad m => Shaft r m b c -> Shaft r m (d, b) (d, c)+  -- Don't use *** as an optimization, as it will require running first twice.+  second (Shaft bc) = Shaft $ PP.map swap+    P.>-> runShaft (first $ Shaft bc)+    -- P.>->  (_Unwrapping Shaft %~ first $ bc)+    P.>-> PP.map swap++  -- Note: The following works, but may not actually be more optimal than default (***)+  -- So maybe it's better to reduce the amount of code to maintain.+  -- -- |Split the input between the two argument pipes and combine their output.+  -- -- (***) :: Monad m => Shaft r m b c -> Shaft r m b' c' -> Shaft r m (b, b') (c, c')+  -- (Shaft bc) *** (Shaft bc') = Shaft $ PL.evalStateP Nothing go -- State :: Maybe (Either c b')+  --  where+  --   justb' (_, b') = Just (Right b')++  --   -- store (Just (Left c)), and yields b'+  --   storec = forever $ do+  --     c <- P.await -- c from output of pipe bc+  --     s <- get -- Just (Right b') from storage+  --     put $ Just (Left c) -- store (Just (Left c))+  --     case s of+  --       Just (Right b') -> P.yield b'+  --       _ -> pure () -- shouldn't happen++  --   -- get (Just (Left c)) from stroage, and combine with awaited c'+  --   outcc' = forever $ do+  --     c' <- P.await -- c' from output of pipe bc'+  --     s <- get -- Just (Left c) from storage+  --     case s of+  --       Just (Left c) -> P.yield (c, c')+  --       _ -> pure () -- shouldn't happen++  --   go = store' justb' -- store (Just (Right b'))+  --     P.>-> PP.map fst -- get b from (b, b')+  --     P.>-> P.hoist lift bc -- make original pipe bc stateful+  --     P.>-> storec -- store (Just (Left c)), and yields b'+  --     P.>-> P.hoist lift bc' -- make original pipe bc' stateful+  --     P.>-> outcc'++instance Monad m => ArrowChoice (Shaft r m) where+  left (Shaft a) = Shaft (PE.left a)+  right (Shaft a) = Shaft (PE.right a)+  (Shaft a) +++ (Shaft b) = Shaft (a PE.+++ b)

@@ -1,2 +1,100 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++module Main where++import Control.Arrow+import Data.Foldable+import qualified Pipes as P+import qualified Pipes.Shaft as PS+import qualified Pipes.Prelude as PP+import Test.Hspec++data1 :: [Int]+data1 = [1, 2..9]++data2 :: [Either Int String]+data2 = [ Left 1+        , Right "a"+        , Left 2+        , Right "b"+        , Left 3+        , Right "c"+        , Left 4+        , Right "d"+        , Left 5+        , Right "e"+        ]++sig1 :: Monad m => P.Producer Int m ()+sig1 = traverse_ P.yield data1++sig2 :: Monad m => P.Producer (Either Int String) m ()+sig2 = traverse_ P.yield data2++duplicate :: a -> (a, a)+duplicate a = (a, a)+ main :: IO ()-main = putStrLn "Test suite not yet implemented"+main =+  hspec $ do+      describe "Arrow" $ do+          it "first" $ do+              let xs = PP.toList+                      (sig1+                       P.>-> PP.map duplicate+                       P.>-> PS.runShaft (first $ PS.Shaft (PP.map (+ 10))))+              xs `shouldBe` zip ((+ 10) <$> data1) data1++          it "second" $ do+              let xs = PP.toList+                       (sig1+                        P.>-> PP.map duplicate+                        P.>-> PS.runShaft (second $ PS.Shaft (PP.map (+ 10))))+              xs `shouldBe` zip data1 ((+ 10) <$> data1)++          it "***" $ do+              let xs = PP.toList+                       (sig1+                        P.>-> PP.map duplicate+                        P.>-> PS.runShaft (PS.Shaft (PP.map (+ 10)) *** PS.Shaft (PP.map (+ 20))))+              xs `shouldBe` zip ((+ 10) <$> data1) ((+ 20)<$> data1)++          it "&&&" $ do+              let xs = PP.toList+                       (sig1+                        P.>-> PS.runShaft (PS.Shaft (PP.map (+ 10)) &&& PS.Shaft (PP.map (+ 20))))+              xs `shouldBe` zip ((+ 10) <$> data1) ((+ 20)<$> data1)++      describe "ArrowChoice" $ do+          it "left" $ do+              let xs = PP.toList+                       (sig2+                        P.>-> PS.runShaft (left $ PS.Shaft (PP.map (+ 10))))+              xs `shouldBe` ((\a -> case a of+                                     Left a' -> Left (a' + 10)+                                     Right a' -> Right a') <$> data2)++          it "right" $ do+              let xs = PP.toList+                       (sig2+                        P.>-> PS.runShaft (right $ PS.Shaft (PP.map (++ "!"))))+              xs `shouldBe` ((\a -> case a of+                                     Left a' -> Left a'+                                     Right a' -> Right (a' ++ "!")) <$> data2)++          it "+++" $ do+              let xs = PP.toList+                       (sig2+                        P.>-> PS.runShaft (PS.Shaft (PP.map (+ 10)) +++ PS.Shaft (PP.map (++ "!"))))+              xs `shouldBe` ((\a -> case a of+                                     Left a' -> Left (a' + 10)+                                     Right a' -> Right (a' ++ "!")) <$> data2)+++          it "|||" $ do+              let xs = PP.toList+                       (sig2+                        P.>-> PS.runShaft (PS.Shaft (PP.map (show . (+ 10))) ||| PS.Shaft (PP.map (++ "!"))))+              xs `shouldBe` ((\a -> case a of+                                     Left a' -> show (a' + 10)+                                     Right a' -> a' ++ "!") <$> data2)