packages feed

fusion (empty) → 0.1.0

raw patch · 5 files changed

+304/−0 lines, 5 filesdep +basedep +directorydep +doctestsetup-changed

Dependencies added: base, directory, doctest, filepath, pipes-safe, transformers

Files

+ Fusion.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}++module Fusion+    (+    -- * Step+    Step(..)+    -- * StepList+    , StepList(..)+    -- * Stream+    , Stream(..), mapS, concatS, fromList, fromListM+    , toListS, lazyToListS, runEffect, emptyStream+    , bracketS, next+    -- * StreamList+    , ListT(..), concat+    -- * Pipes+    , Producer, Pipe, Consumer+    , each, mapP+    )+    where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Class+import Data.Foldable+import Data.Functor.Identity+import Data.Void+import Pipes.Safe+import System.IO.Unsafe++-- Step++-- | A simple stepper, as suggested by Duncan Coutts in his Thesis paper,+-- "Stream Fusion: Practical shortcut fusion for coinductive sequence types".+-- This version adds a result type.+data Step s a r = Done r | Skip s | Yield s a deriving Functor++-- StepList++newtype StepList s r a = StepList { getStepList :: Step s a r }++instance Functor (StepList s r) where+    fmap _ (StepList (Done r))    = StepList $ Done r+    fmap _ (StepList (Skip s))    = StepList $ Skip s+    fmap f (StepList (Yield s a)) = StepList $ Yield s (f a)+    {-# INLINE fmap #-}++-- Stream++data Stream a m r where+    Stream :: (s -> m (Step s a r)) -> m s -> Stream a m r++instance Show a => Show (Stream a Identity r) where+    show xs = "Stream " ++ show (runIdentity (toListS xs))++instance Functor m => Functor (Stream a m) where+    fmap f (Stream k m) = Stream (fmap (fmap f) . k) m+    {-# INLINE fmap #-}++instance Monad m => Applicative (Stream a m) where+    pure x = Stream (pure . Done) (pure x)+    {-# INLINE pure #-}+    sf <*> sx = Stream (pure . Done) (runEffect sf <*> runEffect sx)+    {-# INLINE (<*>) #-}++instance MonadTrans (Stream a) where+    lift = Stream (return . Done)+    {-# INLINE lift #-}++-- | Map over the values produced by a stream.+--+-- >>> mapS (+1) (fromList [1..3]) :: Stream Int Identity ()+-- Stream [2,3,4]+mapS :: Functor m => (a -> b) -> Stream a m r -> Stream b m r+mapS f (Stream s i) = Stream (fmap go . s) i+  where+    go (Done r)     = Done r+    go (Skip s')    = Skip s'+    go (Yield s' a) = Yield s' (f a)+{-# INLINE mapS #-}++concatS :: Monad m => Stream (Stream a m r) m r -> Stream a m r+concatS (Stream xs i) =+    Stream (\case Left  s       -> xs s >>= go Nothing+                  Right (st, t) -> go (Just t) st)+           (Left `liftM` i)+  where+    go _ (Done r) = return $ Done r+    go _ (Skip s) = return $ Skip (Left s)++    go Nothing e@(Yield _ z)              = go (Just z) e+    go (Just (Stream ys j)) e@(Yield s _) = go' `liftM` (j >>= ys)+      where+        go' (Done _)    = Skip (Left s)+        go' (Skip s')   = Skip (Right (e, Stream ys (pure s')))+        go' (Yield s' a) = Yield (Right (e, Stream ys (pure s'))) a+{-# SPECIALIZE concatS :: Stream (Stream a IO r) IO r -> Stream a IO r #-}++fromList :: Foldable f => Applicative m => f a -> Stream a m ()+fromList = Stream (\case []     -> pure $ Done ()+                         (x:xs) -> pure $ Yield xs x) . pure . toList+{-# INLINE fromList #-}++fromListM :: (Monad m, Foldable f) => m (f a) -> Stream a m ()+fromListM xs = Stream (\case []     -> return $ Done ()+                             (y:ys) -> return $ Yield ys y)+                      (toList <$> xs)+{-# INLINE fromListM #-}++runEffect :: Monad m => Stream a m r -> m r+runEffect (Stream f i) = i >>= f >>= go+  where+    go (Done r)    = return r+    go (Skip s)    = f s >>= go+    go (Yield s _) = f s >>= go+{-# INLINE runEffect #-}++toListS :: Monad m => Stream a m r -> m [a]+toListS (Stream f i) = i >>= f >>= go+  where+    go (Done _)   = return []+    go (Skip s)    = f s >>= go+    go (Yield s a) = f s >>= liftM (a:) . go+{-# INLINE toListS #-}++lazyToListS :: Stream a IO r -> IO [a]+lazyToListS (Stream f i) = i >>= f >>= go+  where+    go (Done _)   = return []+    go (Skip s)    = f s >>= go+    go (Yield s a) = f s >>= liftM (a:) . unsafeInterleaveIO . go+{-# INLINE lazyToListS #-}++emptyStream :: Monad m => Stream Void m ()+emptyStream = pure ()+{-# INLINE emptyStream #-}++bracketS :: (Monad m, MonadMask m, MonadSafe m)+         => Base m s+         -> (s -> Base m ())+         -> (forall r. s -> (a -> s -> m r) -> (s -> m r) -> m r -> m r)+         -> Stream a m ()+bracketS i f step = Stream go $ mask $ \_unmask -> do+    s <- liftBase i+    key <- register (f s)+    return (s, key)+  where+    go (s, key) =+        step s (\a s' -> return $ Yield (s', key) a)+               (\s'   -> return $ Skip (s', key))+               (release key >> (const (Done ()) `liftM` liftBase (f s)))+{-# SPECIALIZE bracketS+      :: IO s+      -> (s -> IO ())+      -> (forall r. s -> (a -> s -> SafeT IO r)+           -> (s -> SafeT IO r)+           -> SafeT IO r+           -> SafeT IO r)+      -> Stream a (SafeT IO) () #-}++next :: Monad m => Stream a m r -> m (Either r (a, Stream a m r))+next (Stream xs i) = do+    s <- i+    x <- xs s+    case x of+        Done r     -> return $ Left r+        Skip s'    -> next (Stream xs (return s'))+        Yield s' a -> return $ Right (a, Stream xs (return s'))+{-# SPECIALIZE next :: Stream a IO r -> IO (Either r (a, Stream a IO r)) #-}++-- ListT++newtype ListT m a = ListT { getListT :: Stream a m () }++instance Functor m => Functor (ListT m) where+    fmap f (ListT s) = ListT $ mapS f s+    {-# INLINE fmap #-}++instance Monad m => Applicative (ListT m) where+    pure = return+    {-# INLINE pure #-}+    (<*>) = ap+    {-# INLINE (<*>) #-}++instance Monad m => Monad (ListT m) where+    return x = ListT $ fromList [x]+    {-# INLINE return #-}+    m >>= f = concatL $ fmap f m+    {-# INLINE (>>=) #-}++concatL :: Monad m => ListT m (ListT m a) -> ListT m a+concatL = ListT . concatS . getListT . fmap getListT+{-# INLINE concatL #-}++-- Pipes++type Producer   b m r = Stream b m r+type Pipe     a b m r = Stream a m () -> Stream b m r+type Consumer a   m r = Stream a m () -> m r++each :: (Monad m, Foldable f) => f a -> Producer a m ()+each = fromList+{-# INLINE each #-}++mapP :: Monad m => (a -> b) -> Pipe a b m ()+mapP f = getListT . fmap f . ListT+{-# INLINE mapP #-}
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, John Wiegley++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 John Wiegley 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fusion.cabal view
@@ -0,0 +1,33 @@+name:                fusion+version:             0.1.0+synopsis:            Effectful streaming library based on shortcut fusion techniques+description:         Effectful streaming library based on shortcut fusion techniques+homepage:            https://github.com/jwiegley/fusion+license:             BSD3+license-file:        LICENSE+author:              John Wiegley+maintainer:          johnw@newartisans.com+copyright:           Copyright (c) 2015, John Wiegley. All Rights Reserved.+category:            Data+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Fusion+  other-extensions:    DeriveFunctor, LambdaCase, RankNTypes, GADTs+  build-depends:       +      base         >=4.8 && <4.9+    , transformers >=0.4 && <0.5+    , pipes-safe   >=2.2 && <3+  default-language:    Haskell2010++Test-suite doctests+  default-language: Haskell98+  type:    exitcode-stdio-1.0+  main-is: doctest.hs+  hs-source-dirs: test+  build-depends:      +      base+    , directory    >=1.0+    , doctest      >=0.8+    , filepath     >=1.3
+ test/doctest.hs view
@@ -0,0 +1,29 @@+module Main where++import Test.DocTest+import System.Directory+import System.FilePath+import Control.Applicative+import Control.Monad+import Data.List++main :: IO ()+main = getSources >>= \sources -> doctest $+    "-idist/build/autogen"+  : "-optP-include"+  : "-optPdist/build/autogen/cabal_macros.h"+  : sources++getSources :: IO [FilePath]+getSources =+    filter (\n -> ".hs" `isSuffixOf` n) <$> pure ["Fusion.hs"]+--   where+--     go dir = do+--       (dirs, files) <- getFilesAndDirectories dir+--       (files ++) . concat <$> mapM go dirs++-- getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+-- getFilesAndDirectories dir = do+--     c <- map (dir </>) . filter (`notElem` ["..", "."])+--              <$> getDirectoryContents dir+--     (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c