385 lines
12 KiB
Haskell
385 lines
12 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DeriveFunctor #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
module Servant.Types.SourceT where
|
|
|
|
import Control.Monad.Except
|
|
(ExceptT (..), runExceptT, throwError)
|
|
import Control.Monad.Morph
|
|
(MFunctor (..))
|
|
import Control.Monad.Trans.Class
|
|
(MonadTrans (..))
|
|
import qualified Data.Attoparsec.ByteString as A
|
|
import qualified Data.ByteString as BS
|
|
import Data.Functor.Classes
|
|
(Show1 (..), showsBinaryWith, showsPrec1, showsUnaryWith)
|
|
import Data.Functor.Identity
|
|
(Identity (..))
|
|
import Prelude ()
|
|
import Prelude.Compat hiding
|
|
(readFile)
|
|
import System.IO
|
|
(Handle, IOMode (..), withFile)
|
|
import qualified Test.QuickCheck as QC
|
|
|
|
-- $setup
|
|
-- >>> :set -XOverloadedStrings
|
|
-- >>> import Control.Monad.Except (runExcept)
|
|
-- >>> import Data.Foldable (toList)
|
|
-- >>> import qualified Data.Attoparsec.ByteString.Char8 as A8
|
|
|
|
-- | This is CPSised ListT.
|
|
--
|
|
-- @since 0.15
|
|
--
|
|
newtype SourceT m a = SourceT
|
|
{ unSourceT :: forall b. (StepT m a -> m b) -> m b
|
|
}
|
|
|
|
mapStepT :: (StepT m a -> StepT m b) -> SourceT m a -> SourceT m b
|
|
mapStepT f (SourceT m) = SourceT $ \k -> m (k . f)
|
|
{-# INLINE mapStepT #-}
|
|
|
|
-- | @ListT@ with additional constructors.
|
|
--
|
|
-- @since 0.15
|
|
--
|
|
data StepT m a
|
|
= Stop
|
|
| Error String -- we can this argument configurable.
|
|
| Skip (StepT m a) -- Note: not sure about this constructor
|
|
| Yield a (StepT m a)
|
|
| Effect (m (StepT m a))
|
|
deriving Functor
|
|
|
|
-- | Create 'SourceT' from 'Step'.
|
|
--
|
|
-- /Note:/ often enough you want to use 'SourceT' directly.
|
|
fromStepT :: StepT m a -> SourceT m a
|
|
fromStepT s = SourceT ($ s)
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- SourceT instances
|
|
-------------------------------------------------------------------------------
|
|
|
|
instance Functor m => Functor (SourceT m) where
|
|
fmap f = mapStepT (fmap f)
|
|
|
|
-- | >>> toList (source [1..10])
|
|
-- [1,2,3,4,5,6,7,8,9,10]
|
|
--
|
|
instance Identity ~ m => Foldable (SourceT m) where
|
|
foldr f z (SourceT m) = foldr f z (runIdentity (m Identity))
|
|
|
|
instance (Applicative m, Show1 m) => Show1 (SourceT m) where
|
|
liftShowsPrec sp sl d (SourceT m) = showsUnaryWith
|
|
(liftShowsPrec sp sl)
|
|
"fromStepT" d (Effect (m pure'))
|
|
where
|
|
pure' (Effect s) = s
|
|
pure' s = pure s
|
|
|
|
instance (Applicative m, Show1 m, Show a) => Show (SourceT m a) where
|
|
showsPrec = showsPrec1
|
|
|
|
-- | >>> hoist (Just . runIdentity) (source [1..3]) :: SourceT Maybe Int
|
|
-- fromStepT (Effect (Just (Yield 1 (Yield 2 (Yield 3 Stop)))))
|
|
instance MFunctor SourceT where
|
|
hoist f (SourceT m) = SourceT $ \k -> k $
|
|
Effect $ f $ fmap (hoist f) $ m return
|
|
|
|
-- | >>> source "xy" <> source "z" :: SourceT Identity Char
|
|
-- fromStepT (Effect (Identity (Yield 'x' (Yield 'y' (Yield 'z' Stop)))))
|
|
--
|
|
instance Functor m => Semigroup (SourceT m a) where
|
|
SourceT withL <> SourceT withR = SourceT $ \ret ->
|
|
withL $ \l ->
|
|
withR $ \r ->
|
|
ret $ l <> r
|
|
|
|
-- | >>> mempty :: SourceT Maybe Int
|
|
-- fromStepT (Effect (Just Stop))
|
|
instance Functor m => Monoid (SourceT m a) where
|
|
mempty = fromStepT mempty
|
|
mappend = (<>)
|
|
|
|
-- | Doesn't generate 'Error' constructors. 'SourceT' doesn't shrink.
|
|
instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (SourceT m a) where
|
|
arbitrary = fromStepT <$> QC.arbitrary
|
|
|
|
-- An example of above instance. Not doctested because it's volatile.
|
|
--
|
|
-- >>> import Test.QuickCheck as QC
|
|
-- >>> import Test.QuickCheck.Gen as QC
|
|
-- >>> import Test.QuickCheck.Random as QC
|
|
-- >>> let generate (QC.MkGen g) = g (QC.mkQCGen 44) 10
|
|
--
|
|
-- >>> generate (arbitrary :: QC.Gen (SourceT Identity Int))
|
|
-- fromStepT (Effect (Identity (Yield (-10) (Yield 3 (Skip (Yield 1 Stop))))))
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- StepT instances
|
|
-------------------------------------------------------------------------------
|
|
|
|
instance Identity ~ m => Foldable (StepT m) where
|
|
foldr f z = go where
|
|
go Stop = z
|
|
go (Error _) = z
|
|
go (Skip s) = go s
|
|
go (Yield a s) = f a (go s)
|
|
go (Effect (Identity s)) = go s
|
|
|
|
instance (Applicative m, Show1 m) => Show1 (StepT m) where
|
|
liftShowsPrec sp sl = go where
|
|
go _ Stop = showString "Stop"
|
|
go d (Skip s) = showsUnaryWith
|
|
go
|
|
"Skip" d s
|
|
go d (Error err) = showsUnaryWith
|
|
showsPrec
|
|
"Error" d err
|
|
go d (Effect ms) = showsUnaryWith
|
|
(liftShowsPrec go goList)
|
|
"Effect" d ms
|
|
go d (Yield x s) = showsBinaryWith
|
|
sp go
|
|
"Yield" d x s
|
|
|
|
goList = liftShowList sp sl
|
|
|
|
instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where
|
|
showsPrec = showsPrec1
|
|
|
|
-- | >>> lift [1,2,3] :: StepT [] Int
|
|
-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]
|
|
--
|
|
#if !MIN_VERSION_transformers(0,6,0)
|
|
instance MonadTrans StepT where
|
|
lift = Effect . fmap (`Yield` Stop)
|
|
#endif
|
|
|
|
instance MFunctor StepT where
|
|
hoist f = go where
|
|
go Stop = Stop
|
|
go (Error err) = Error err
|
|
go (Skip s) = Skip (go s)
|
|
go (Yield x s) = Yield x (go s)
|
|
go (Effect ms) = Effect (f (fmap go ms))
|
|
|
|
instance Functor m => Semigroup (StepT m a) where
|
|
Stop <> r = r
|
|
Error err <> _ = Error err
|
|
Skip s <> r = Skip (s <> r)
|
|
Yield x s <> r = Yield x (s <> r)
|
|
Effect ms <> r = Effect ((<> r) <$> ms)
|
|
|
|
-- | >>> mempty :: StepT [] Int
|
|
-- Stop
|
|
--
|
|
-- >>> mempty :: StepT Identity Int
|
|
-- Stop
|
|
--
|
|
instance Functor m => Monoid (StepT m a) where
|
|
mempty = Stop
|
|
mappend = (<>)
|
|
|
|
-- | Doesn't generate 'Error' constructors.
|
|
instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (StepT m a) where
|
|
arbitrary = QC.sized arb where
|
|
arb n | n <= 0 = pure Stop
|
|
| otherwise = QC.frequency
|
|
[ (1, pure Stop)
|
|
, (1, Skip <$> arb')
|
|
, (1, Effect . return <$> arb')
|
|
, (8, Yield <$> QC.arbitrary <*> arb')
|
|
]
|
|
where
|
|
arb' = arb (n - 1)
|
|
|
|
shrink Stop = []
|
|
shrink (Error _) = [Stop]
|
|
shrink (Skip s) = [s]
|
|
shrink (Effect _) = []
|
|
shrink (Yield x s) =
|
|
[ Yield x' s | x' <- QC.shrink x ] ++
|
|
[ Yield x s' | s' <- QC.shrink s ]
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Operations
|
|
-------------------------------------------------------------------------------
|
|
|
|
-- | Create pure 'SourceT'.
|
|
--
|
|
-- >>> source "foo" :: SourceT Identity Char
|
|
-- fromStepT (Effect (Identity (Yield 'f' (Yield 'o' (Yield 'o' Stop)))))
|
|
--
|
|
source :: [a] -> SourceT m a
|
|
source = fromStepT . foldr Yield Stop
|
|
|
|
-- | Get the answers.
|
|
--
|
|
-- >>> runSourceT (source "foo" :: SourceT Identity Char)
|
|
-- ExceptT (Identity (Right "foo"))
|
|
--
|
|
-- >>> runSourceT (source "foo" :: SourceT [] Char)
|
|
-- ExceptT [Right "foo"]
|
|
--
|
|
runSourceT :: Monad m => SourceT m a -> ExceptT String m [a]
|
|
runSourceT (SourceT m) = ExceptT (m (runExceptT . runStepT))
|
|
|
|
runStepT :: Monad m => StepT m a -> ExceptT String m [a]
|
|
runStepT Stop = return []
|
|
runStepT (Error err) = throwError err
|
|
runStepT (Skip s) = runStepT s
|
|
runStepT (Yield x s) = fmap (x :) (runStepT s)
|
|
runStepT (Effect ms) = lift ms >>= runStepT
|
|
|
|
{-
|
|
-- | >>> uncons (foldr Yield Stop "foo" :: StepT Identity Char)
|
|
-- Identity (Just ('f',Yield 'o' (Yield 'o' Stop)))
|
|
--
|
|
uncons :: Monad m => StepT m a -> m (Maybe (a, StepT m a))
|
|
uncons Stop = return Nothing
|
|
uncons (Skip s) = uncons s
|
|
uncons (Yield x s) = return (Just (x, s))
|
|
uncons (Effect ms) = ms >>= uncons
|
|
uncons (Error _) =
|
|
-}
|
|
|
|
-- | Filter values.
|
|
--
|
|
-- >>> toList $ mapMaybe (\x -> if odd x then Just x else Nothing) (source [0..10]) :: [Int]
|
|
-- [1,3,5,7,9]
|
|
--
|
|
-- >>> mapMaybe (\x -> if odd x then Just x else Nothing) (source [0..2]) :: SourceT Identity Int
|
|
-- fromStepT (Effect (Identity (Skip (Yield 1 (Skip Stop)))))
|
|
--
|
|
-- Illustrates why we need 'Skip'.
|
|
mapMaybe :: Functor m => (a -> Maybe b) -> SourceT m a -> SourceT m b
|
|
mapMaybe p (SourceT m) = SourceT $ \k -> m (k . mapMaybeStep p)
|
|
|
|
mapMaybeStep :: Functor m => (a -> Maybe b) -> StepT m a -> StepT m b
|
|
mapMaybeStep p = go where
|
|
go Stop = Stop
|
|
go (Error err) = Error err
|
|
go (Skip s) = Skip (go s)
|
|
go (Effect ms) = Effect (fmap go ms)
|
|
go (Yield x s) = case p x of
|
|
Nothing -> Skip (go s)
|
|
Just y -> Yield y (go s)
|
|
|
|
-- | Run action for each value in the 'SourceT'.
|
|
--
|
|
-- >>> foreach fail print (source "abc")
|
|
-- 'a'
|
|
-- 'b'
|
|
-- 'c'
|
|
--
|
|
foreach
|
|
:: Monad m
|
|
=> (String -> m ()) -- ^ error handler
|
|
-> (a -> m ())
|
|
-> SourceT m a
|
|
-> m ()
|
|
foreach f g src = unSourceT src (foreachStep f g)
|
|
|
|
-- | See 'foreach'.
|
|
foreachStep
|
|
:: Monad m
|
|
=> (String -> m ()) -- ^ error handler
|
|
-> (a -> m ())
|
|
-> StepT m a
|
|
-> m ()
|
|
foreachStep f g = go where
|
|
go Stop = return ()
|
|
go (Skip s) = go s
|
|
go (Yield x s) = g x >> go s
|
|
go (Error err) = f err
|
|
go (Effect ms) = ms >>= go
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Monadic
|
|
-------------------------------------------------------------------------------
|
|
|
|
fromAction :: Functor m => (a -> Bool) -> m a -> SourceT m a
|
|
fromAction stop action = SourceT ($ fromActionStep stop action)
|
|
{-# INLINE fromAction #-}
|
|
|
|
fromActionStep :: Functor m => (a -> Bool) -> m a -> StepT m a
|
|
fromActionStep stop action = loop where
|
|
loop = Effect $ fmap step action
|
|
step x
|
|
| stop x = Stop
|
|
| otherwise = Yield x loop
|
|
{-# INLINE fromActionStep #-}
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- File
|
|
-------------------------------------------------------------------------------
|
|
|
|
-- | Read file.
|
|
--
|
|
-- >>> foreach fail BS.putStr (readFile "servant.cabal")
|
|
-- cabal-version: 2.2
|
|
-- name: servant
|
|
-- ...
|
|
--
|
|
readFile :: FilePath -> SourceT IO BS.ByteString
|
|
readFile fp =
|
|
SourceT $ \k ->
|
|
withFile fp ReadMode $ \hdl ->
|
|
k (readHandle hdl)
|
|
where
|
|
readHandle :: Handle -> StepT IO BS.ByteString
|
|
readHandle hdl = fromActionStep BS.null (BS.hGet hdl 4096)
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Attoparsec
|
|
-------------------------------------------------------------------------------
|
|
|
|
-- | Transform using @attoparsec@ parser.
|
|
--
|
|
-- Note: @parser@ should not accept empty input!
|
|
--
|
|
-- >>> let parser = A.skipWhile A8.isSpace_w8 >> A.takeWhile1 A8.isDigit_w8
|
|
--
|
|
-- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1 2 3"])
|
|
-- Right ["1","2","3"]
|
|
--
|
|
-- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1", "2", "3"])
|
|
-- Right ["123"]
|
|
--
|
|
-- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1", "2 3", "4"])
|
|
-- Right ["12","34"]
|
|
--
|
|
-- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["foobar"])
|
|
-- Left "Failed reading: takeWhile1"
|
|
--
|
|
transformWithAtto :: Monad m => A.Parser a -> SourceT m BS.ByteString -> SourceT m a
|
|
transformWithAtto parser = mapStepT (transformStepWithAtto parser)
|
|
|
|
transformStepWithAtto
|
|
:: forall a m. Monad m
|
|
=> A.Parser a -> StepT m BS.ByteString -> StepT m a
|
|
transformStepWithAtto parser = go (A.parse parser) where
|
|
p0 = A.parse parser
|
|
|
|
go :: (BS.ByteString -> A.Result a)
|
|
-> StepT m BS.ByteString -> StepT m a
|
|
go _ (Error err) = Error err
|
|
go p (Skip s) = Skip (go p s)
|
|
go p (Effect ms) = Effect (fmap (go p) ms)
|
|
go p Stop = case p mempty of
|
|
A.Fail _ _ err -> Error err
|
|
A.Done _ a -> Yield a Stop
|
|
A.Partial _ -> Stop
|
|
go p (Yield bs0 s) = loop p bs0 where
|
|
loop p' bs
|
|
| BS.null bs = Skip (go p' s)
|
|
| otherwise = case p' bs of
|
|
A.Fail _ _ err -> Error err
|
|
A.Done bs' a -> Yield a (loop p0 bs')
|
|
A.Partial p'' -> Skip (go p'' s)
|