packages feed

fraxl 0.1.0.0 → 0.2.0.0

raw patch · 11 files changed

+259/−321 lines, 11 filesdep +vinyldep −vinyl-plusdep ~asyncdep ~dependent-mapdep ~dependent-sumsetup-changed

Dependencies added: vinyl

Dependencies removed: vinyl-plus

Dependency ranges changed: async, dependent-map, dependent-sum, exceptions, free, mtl, transformers, type-aligned

Files

README.md view
@@ -1,7 +1,7 @@ Fraxl --- -[Documentation](http://elvishjerricco.github.io/fraxl/fraxl-0.1.0.0/)+[Hackage](https://hackage.haskell.org/package/fraxl) • [Presentation](https://youtu.be/Fe3-N9mKuPA)  Fraxl is a library based on Facebook's [Haxl](https://github.com/facebook/Haxl). The goal is to decompose Haxl into more general parts,
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple+import           Distribution.Simple main = defaultMain
examples/src/Main.hs view
@@ -15,7 +15,9 @@ main :: IO () main = do   let fraxl = (++) <$> myFraxl <*> myFraxl-  (strs, reqs) <- runStateT (evalCachedFraxl (fetchMySource |:| fetchMySource2 |:| fetchNil) fraxl) 0+  (strs, reqs) <- runStateT+    (evalCachedFraxl (fetchMySource |:| fetchMySource2 |:| fetchNil) fraxl)+    0   putStrLn ("Number of MySource2 requests made: " ++ show reqs)   print $ length strs   print strs@@ -39,7 +41,8 @@   MyInt `gcompare` MyInt = GEQ  fetchMySource :: MonadIO m => Fetch MySource m a-fetchMySource = simpleAsyncFetch simpleFetch where+fetchMySource = simpleAsyncFetch simpleFetch+ where   simpleFetch :: MySource a -> IO a   simpleFetch MyString = do     putStrLn "Sleeping String!"@@ -72,9 +75,10 @@   MyInt2 `gcompare` MyInt2 = GEQ  fetchMySource2 :: (MonadIO m, MonadState Int m) => Fetch MySource2 m a-fetchMySource2 a = modify (+ clength a) >> simpleAsyncFetch simpleFetch a where+fetchMySource2 a = modify (+ clength a) >> simpleAsyncFetch simpleFetch a+ where   clength :: ASeq f r -> Int-  clength ANil = 0+  clength ANil         = 0   clength (ACons _ rs) = 1 + clength rs   simpleFetch :: MySource2 a -> IO a   simpleFetch MyString2 = do
fraxl.cabal view
@@ -1,69 +1,66 @@-name:                fraxl-version:             0.1.0.0-synopsis:            Cached and parallel data fetching.-description:         Fraxl is a free monad designed to make concurrent data fetching easy.-homepage:            https://github.com/ElvishJerricco/fraxl-license:             BSD3-license-file:        LICENSE-author:              Will Fancher-maintainer:          willfancher38@gmail.com-copyright:           2016 Will Fancher-category:            Concurrency-build-type:          Simple-extra-source-files:  README.md-cabal-version:       >=1.10+cabal-version: >=1.10+name: fraxl+version: 0.2.0.0+license: BSD3+license-file: LICENSE+copyright: 2016 Will Fancher+maintainer: willfancher38@gmail.com+author: Will Fancher+homepage: https://github.com/ElvishJerricco/fraxl+synopsis: Cached and parallel data fetching.+description:+    Fraxl is a free monad designed to make concurrent data fetching easy.+category: Concurrency+build-type: Simple+extra-source-files:+    README.md +source-repository head+    type: git+    location: https://github.com/ElvishJerricco/fraxl+ library-  hs-source-dirs:      src-  exposed-modules:     Control.Monad.Fraxl-                     , Control.Monad.Fraxl.Class-                     , Control.Monad.Trans.Fraxl-                     , Control.Monad.Trans.Fraxl.Free-                     , Control.Applicative.Fraxl.Free-  build-depends:       base >= 4.7 && < 5-                     , async-                     , exceptions-                     , free-                     , transformers-                     , mtl-                     , dependent-sum-                     , dependent-map-                     , vinyl-plus-                     , type-aligned-  ghc-options:         -Wall-  default-language:    Haskell2010+    exposed-modules:+        Control.Monad.Fraxl+        Control.Monad.Fraxl.Class+        Control.Monad.Trans.Fraxl+        Control.Monad.Trans.Fraxl.Free+    hs-source-dirs: src+    default-language: Haskell2010+    ghc-options: -Wall+    build-depends:+        base >=4.8 && <5,+        async >=2.1.1.1 && <2.3,+        exceptions >=0.8.3 && <0.11,+        free >=5.0.2 && <5.2,+        transformers >=0.4.2.0 && <0.6,+        mtl >=2.2.2 && <2.3,+        dependent-sum ==0.4.*,+        dependent-map >=0.2.4.0 && <0.3,+        vinyl >=0.6 && <0.9,+        type-aligned >=0.9.6 && <0.10  test-suite examples-  type:                exitcode-stdio-1.0-  main-is:             Main.hs-  build-depends:       base-                     , fraxl-                     , transformers-                     , mtl-  hs-source-dirs:      examples/src-  ghc-options:         -Wall-  default-language:    Haskell2010+    type: exitcode-stdio-1.0+    main-is: Main.hs+    hs-source-dirs: examples/src+    default-language: Haskell2010+    ghc-options: -Wall+    build-depends:+        base -any,+        fraxl -any,+        transformers -any,+        mtl -any  test-suite monadbench-  type:                exitcode-stdio-1.0-  hs-source-dirs:      tests-  main-is:             MonadBench.hs-  other-modules:       ExampleDataSource-  build-depends:       base-                     , fraxl-                     , time-  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N-  default-language:    Haskell2010---- test-suite fraxl-test---   type:                exitcode-stdio-1.0---   hs-source-dirs:      test---   main-is:             Spec.hs---   build-depends:       base---                      , fraxl---   ghc-options:         -threaded -rtsopts -with-rtsopts=-N---   default-language:    Haskell2010--source-repository head-  type:     git-  location: https://github.com/ElvishJerricco/fraxl+    type: exitcode-stdio-1.0+    main-is: MonadBench.hs+    hs-source-dirs: tests+    other-modules:+        ExampleDataSource+    default-language: Haskell2010+    ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        base -any,+        fraxl -any,+        time -any
− src/Control/Applicative/Fraxl/Free.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GADTs              #-}-{-# LANGUAGE RankNTypes         #-}------------------------------------------------------------------------------------ |--- A faster free applicative.--- Based on <https://www.eyrie.org/~zednenem/2013/05/27/freeapp Dave Menendez's work>.----------------------------------------------------------------------------------module Control.Applicative.Fraxl.Free-  ( ASeq(..)-  , reduceASeq-  , Ap(..)-  , liftAp-  , retractAp-  , runAp-  , runAp_-  , hoistASeq-  , traverseASeq-  , rebaseASeq-  , hoistAp-  ) where--import           Control.Applicative-import           Data.Typeable--data ASeq f a where-  ANil :: ASeq f ()-  ACons :: f a -> ASeq f u -> ASeq f (a,u)-  deriving Typeable---- | reduceASeq a sequence of applicative effects into an applicative.-reduceASeq :: Applicative f => ASeq f u -> f u-reduceASeq ANil         = pure ()-reduceASeq (ACons x xs) = (,) <$> x <*> reduceASeq xs---- | Transform a sequence of 'f' into a sequence of 'g'.-hoistASeq :: (forall x. f x -> g x) -> ASeq f a -> ASeq g a-hoistASeq _ ANil = ANil-hoistASeq u (ACons x xs) = ACons (u x) (u `hoistASeq` xs)---- | Traverse a sequence with resepect to its interpretation type 'f'.-traverseASeq :: Applicative h => (forall x. f x -> h (g x)) -> ASeq f a -> h (ASeq g a)-traverseASeq _ ANil      = pure ANil-traverseASeq f (ACons x xs) = ACons <$> f x <*> traverseASeq f xs---- | It may not look like it, but this appends two sequences.--- See <https://www.eyrie.org/~zednenem/2013/05/27/freeapp Dave Menendez's work> for more explanation.-rebaseASeq :: ASeq f u -> (forall x. (x -> y) -> ASeq f x -> z) ->-  (v -> u -> y) -> ASeq f v -> z-rebaseASeq ANil         k f = k (`f` ())-rebaseASeq (ACons x xs) k f =-  rebaseASeq xs (\g s -> k (\(a,u) -> g u a) (ACons x s))-    (\v u a -> f v (a,u))----- | The faster free 'Applicative'.-newtype Ap f a = Ap-  { unAp :: forall u y z.-    (forall x. (x -> y) -> ASeq f x -> z) ->-    (u -> a -> y) -> ASeq f u -> z }-  deriving Typeable---- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@.------ prop> runAp t == retractApp . hoistApp t-runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a-runAp u = retractAp . hoistAp u---- | Perform a monoidal analysis over free applicative value.------ Example:------ @--- count :: Ap f a -> Int--- count = getSum . runAp_ (\\_ -> Sum 1)--- @-runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m-runAp_ f = getConst . runAp (Const . f)--instance Functor (Ap f) where-  fmap g x = Ap (\k f -> unAp x k (\s -> f s . g))--instance Applicative (Ap f) where-  pure a = Ap (\k f -> k (`f` a))-  x <*> y = Ap (\k f -> unAp y (unAp x k) (\s a g -> f s (g a)))---- | A version of 'lift' that can be used with just a 'Functor' for @f@.-liftAp :: f a -> Ap f a-liftAp a = Ap (\k f s -> k (\(a',s') -> f s' a') (ACons a s))-{-# INLINE liftAp #-}---- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@.-hoistAp :: (forall x. f x -> g x) -> Ap f a -> Ap g a-hoistAp g x = Ap (\k f s ->-  unAp x-    (\f' s' ->-      rebaseASeq (hoistASeq g s') k-        (\v u -> f v (f' u)) s)-    (const id)-    ANil)---- | Interprets the free applicative functor over f using the semantics for---   `pure` and `<*>` given by the Applicative instance for f.------   prop> retractApp == runAp id-retractAp :: Applicative f => Ap f a -> f a-retractAp x = unAp x (\f s -> f <$> reduceASeq s) (\() -> id) ANil
src/Control/Monad/Fraxl.hs view
@@ -22,7 +22,8 @@   , module Data.GADT.Compare   -- * Fraxl Monads   , MonadFraxl(..)-  ) where+  )+where  import           Control.Monad.Fraxl.Class import           Control.Monad.Trans.Fraxl
src/Control/Monad/Fraxl/Class.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DefaultSignatures     #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-} -- Not actually undecidable. -- @MonadFraxl f (Fraxl r m)@ is not undecidable,@@ -8,40 +9,44 @@ {-# LANGUAGE UndecidableInstances  #-}  module Control.Monad.Fraxl.Class- (+  (  -- * Fraxl Monads-   MonadFraxl(..)- ) where+    MonadFraxl(..)+  )+where -import           Control.Applicative.Fraxl.Free+import           Control.Applicative.Free.Fast import           Control.Monad.Free.Class import           Control.Monad.Trans.Class import           Control.Monad.Trans.Cont import           Control.Monad.Trans.Except import           Control.Monad.Trans.Fraxl import           Control.Monad.Trans.Identity-import           Control.Monad.Trans.List import           Control.Monad.Trans.Maybe import           Control.Monad.Trans.Reader-import qualified Control.Monad.Trans.RWS.Lazy      as Lazy-import qualified Control.Monad.Trans.RWS.Strict    as Strict-import qualified Control.Monad.Trans.State.Lazy    as Lazy-import qualified Control.Monad.Trans.State.Strict  as Strict-import qualified Control.Monad.Trans.Writer.Lazy   as Lazy-import qualified Control.Monad.Trans.Writer.Strict as Strict-import           Data.Vinyl.Optic.Plain.Class-import qualified Data.Vinyl.Prelude.CoRec          as CR-import           Data.Vinyl.Types+import qualified Control.Monad.Trans.RWS.Lazy  as Lazy+import qualified Control.Monad.Trans.RWS.Strict+                                               as Strict+import qualified Control.Monad.Trans.State.Lazy+                                               as Lazy+import qualified Control.Monad.Trans.State.Strict+                                               as Strict+import qualified Control.Monad.Trans.Writer.Lazy+                                               as Lazy+import qualified Control.Monad.Trans.Writer.Strict+                                               as Strict+import           Data.Vinyl+import           Data.Vinyl.CoRec  -- | Class for Fraxl-capable monads. class Monad m => MonadFraxl f m where   -- | 'dataFetch' is used to make a request of type 'f'.   dataFetch :: f a -> m a-  default dataFetch :: (MonadTrans t, MonadFraxl f m) => f a -> t m a+  default dataFetch :: (MonadTrans t, MonadFraxl f n, t n ~ m) => f a -> m a   dataFetch = lift . dataFetch  instance (Monad m, f ∈ r) => MonadFraxl f (Fraxl r m) where-  dataFetch = liftF . liftAp . Union . FunctorCoRec . CR.lift . Flap+  dataFetch = liftF . liftAp . Union . CoRec . Flap  instance Monad m => MonadFraxl f (FreerT f m) where   dataFetch = liftF . liftAp@@ -49,7 +54,6 @@ instance MonadFraxl f m => MonadFraxl f (ContT r m) where instance MonadFraxl f m => MonadFraxl f (ExceptT e m) where instance MonadFraxl f m => MonadFraxl f (IdentityT m) where-instance MonadFraxl f m => MonadFraxl f (ListT m) where instance MonadFraxl f m => MonadFraxl f (MaybeT m) where instance MonadFraxl f m => MonadFraxl f (ReaderT e m) where instance (MonadFraxl f m, Monoid w) => MonadFraxl f (Lazy.RWST r w s m) where
src/Control/Monad/Trans/Fraxl.hs view
@@ -1,11 +1,14 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}  module Control.Monad.Trans.Fraxl   (@@ -33,11 +36,11 @@   , module Data.GADT.Compare   -- * Union   , Union(..)-  , getCoRec-  , mkUnion+  , unconsCoRec+  , Flap(..)   ) where -import           Control.Applicative.Fraxl.Free+import           Control.Applicative.Free.Fast import           Control.Arrow import           Control.Concurrent import           Control.Concurrent.Async@@ -45,11 +48,14 @@ import           Control.Monad.IO.Class import           Control.Monad.State import           Control.Monad.Trans.Fraxl.Free-import           Data.Dependent.Map             (DMap)-import qualified Data.Dependent.Map             as DMap+import           Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap import           Data.GADT.Compare-import qualified Data.Vinyl.Prelude.CoRec       as CR-import           Data.Vinyl.Types+import           Data.Maybe (fromJust)+import           Data.Vinyl+import           Data.Vinyl.CoRec+import           Data.Vinyl.Functor (Compose(..), (:.))+import           Data.Vinyl.TypeLevel  -- | Fraxl is based on a particular Freer monad. -- This Freer monad has applicative optimization,@@ -72,7 +78,7 @@ fetchNil _ = error "Not possible - empty union"  -- | Like '(:)' for constructing @Fetch (Union (f ': r))@-(|:|) :: forall f r a m. Monad m+(|:|) :: forall f r a m. (Monad m, RecApplicative r, FoldRec r r)        => (forall a'. Fetch f m a')        -> (forall a'. Fetch (Union r) m a')        -> Fetch (Union (f ': r)) m a@@ -82,13 +88,13 @@            -> ASeq (Union (f ': r)) z            -> m (ASeq m x, ASeq m y, ASeq m z)   runUnion flist ulist ANil = (, , ANil) <$> fetch flist <*> fetchU ulist-  runUnion flist ulist (ACons u us) = case CR.uncons (getCoRec u) of+  runUnion flist ulist (ACons (Union u) us) = case unconsCoRec u of     Left (Flap fa) -> fmap       (\(ACons ma ms, other, rest) -> (ms, other, ACons ma rest))       (runUnion (ACons fa flist) ulist us)     Right u' -> fmap       (\(other, ACons ma ms, rest) -> (other, ms, ACons ma rest))-      (runUnion flist (ACons (mkUnion u') ulist) us)+      (runUnion flist (ACons (Union u') ulist) us)  infixr 5 |:| @@ -174,33 +180,55 @@                    => (forall a'. Fetch f m a') -> FreerT f m a -> m a evalCachedFraxl fetch a = fst <$> runCachedFraxl fetch a DMap.empty --- | 'FunctorCoRec' doesn't implement 'GCompare'.--- To avoid orphan instances, a newtype is defined.------ @Union@ represents a value of any type constructor in @r@ applied with @a@.-newtype Union r a = Union (FunctorCoRec r a)+class RIndex t ts ~ i => FMatch1 t ts i where+  fmatch1' :: Handler r (f t) -> Rec (Maybe :. f) ts -> Either r (Rec (Maybe :. f) (RDelete t ts)) -getCoRec :: Union r a -> CoRec (Flap a) r-getCoRec (Union (FunctorCoRec u)) = u+instance FMatch1 t (t ': ts) 'Z where+  fmatch1' _ (Compose Nothing :& xs) = Right xs+  fmatch1' (H h) (Compose (Just x) :& _) = Left (h x) -mkUnion :: CoRec (Flap a) r -> Union r a-mkUnion u = Union $ FunctorCoRec u+instance (FMatch1 t ts i, RIndex t (s ': ts) ~ 'S i,+          RDelete t (s ': ts) ~ (s ': RDelete t ts))+         => FMatch1 t (s ': ts) ('S i) where+  fmatch1' h (x :& xs) = (x :&) <$> fmatch1' h xs +-- | Handle a single variant of a 'CoRec': either the function is+-- applied to the variant or the type of the 'CoRec' is refined to+-- reflect the fact that the variant is /not/ compatible with the type+-- of the would-be handler+fmatch1 :: (FMatch1 t ts (RIndex t ts),+            RecApplicative ts,+            FoldRec (RDelete t ts) (RDelete t ts))+        => Handler r (f t)+        -> CoRec f ts+        -> Either r (CoRec f (RDelete t ts))+fmatch1 h = fmap (fromJust . firstField)+          . fmatch1' h+          . coRecToRec++unconsCoRec :: (RecApplicative ts, FoldRec ts ts) => CoRec f (t ': ts) -> Either (f t) (CoRec f ts)+unconsCoRec = fmatch1 (H id)++newtype Flap a f = Flap (f a)++-- | @Union@ represents a value of any type constructor in @r@ applied with @a@.+newtype Union r a = Union (CoRec (Flap a) r)+ instance GEq (Union '[]) where   _ `geq` _ = error "Not possible - empty union" -instance (GEq f, GEq (Union r)) => GEq (Union (f ': r)) where-  a `geq` b = case (CR.uncons (getCoRec a), CR.uncons (getCoRec b)) of+instance (RecApplicative r, FoldRec r r, GEq f, GEq (Union r)) => GEq (Union (f ': r)) where+  Union a `geq` Union b = case (unconsCoRec a, unconsCoRec b) of     (Left (Flap fa), Left (Flap fb)) -> fa `geq` fb-    (Right a', Right b') -> mkUnion a' `geq` mkUnion b'+    (Right a', Right b') -> Union a' `geq` Union b'     _ -> Nothing  instance GCompare (Union '[]) where   _ `gcompare` _ = error "Not possible - empty union" -instance (GCompare f, GCompare (Union r)) => GCompare (Union (f ': r)) where-  a `gcompare` b = case (CR.uncons (getCoRec a), CR.uncons (getCoRec b)) of+instance (RecApplicative r, FoldRec r r, GCompare f, GCompare (Union r)) => GCompare (Union (f ': r)) where+  Union a `gcompare` Union b = case (unconsCoRec a, unconsCoRec b) of     (Left (Flap fa), Left (Flap fb)) -> fa `gcompare` fb-    (Right a', Right b')             -> mkUnion a' `gcompare` mkUnion b'+    (Right a', Right b')             -> Union a' `gcompare` Union b'     (Left _, Right _)                -> GLT     (Right _, Left _)                -> GGT
src/Control/Monad/Trans/Fraxl/Free.hs view
@@ -27,7 +27,8 @@   , iterM   -- * Free Monads With Class   , MonadFree(..)-  ) where+  )+where  import           Control.Applicative import           Control.Arrow@@ -67,20 +68,19 @@ --   Impure x k' >>= k = Impure x (k' >=> k) -------------------------------------------------------------------------------- -(>.<) :: (Applicative m, TASequence s)-      => (m b -> m c)-      -> s (Kleisli m) a b-      -> s (Kleisli m) a c+(>.<)+  :: (Applicative m, TASequence s)+  => (m b -> m c)+  -> s (Kleisli m) a b+  -> s (Kleisli m) a c (>.<) f arrs = case tviewr arrs of-  TAEmptyR -> tsingleton $ Kleisli (f . pure)+  TAEmptyR         -> tsingleton $ Kleisli (f . pure)   ks :> Kleisli ar -> ks |> Kleisli (f . ar) -qApp :: (Monad m, TASequence s)-     => s (Kleisli m) a b-     -> Kleisli m a b+qApp :: (Monad m, TASequence s) => s (Kleisli m) a b -> Kleisli m a b qApp arrs = case tviewl arrs of   TAEmptyL -> Kleisli pure-  k :< ks -> k >>> qApp ks+  k :< ks  -> k >>> qApp ks  -- | The base functor for a free monad. data FreeF f m a where@@ -91,13 +91,14 @@   fmap f (Free b k) = Free b (fmap f >.< k)   {-# INLINE fmap #-} -transFreeF :: (Applicative f, Monad m)-           => (forall x. f x -> g x)-           -> FreeF f m a-           -> FreeF g m a-transFreeF _ (Pure a) = Pure a-transFreeF t (Free b k) = Free (t b) k' where-  k' = tmap (Kleisli . (transFreeT t .) . runKleisli) k+transFreeF+  :: (Applicative f, Monad m)+  => (forall x . f x -> g x)+  -> FreeF f m a+  -> FreeF g m a+transFreeF _ (Pure a  ) = Pure a+transFreeF t (Free b k) = Free (t b) k'+  where k' = tmap (Kleisli . (transFreeT t .) . runKleisli) k {-# INLINE transFreeF #-}  -- | The \"free monad transformer\" for an applicative functor @f@@@ -208,58 +209,62 @@ -- | Tear down a free monad transformer using iteration. iterT :: (Applicative f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a iterT f (FreeT m) = do-    val <- m-    case val of-        Pure x -> return x-        Free y k -> f $ fmap (iterT f . runKleisli (qApp k)) y+  val <- m+  case val of+    Pure x   -> return x+    Free y k -> f $ fmap (iterT f . runKleisli (qApp k)) y  -- | Tear down a free monad transformer using iteration over a transformer.-iterTM :: ( Applicative f-          , Monad m-          , MonadTrans t-          , Monad (t m))-          => (f (t m a) -> t m a) -> FreeT f m a -> t m a+iterTM+  :: (Applicative f, Monad m, MonadTrans t, Monad (t m))+  => (f (t m a) -> t m a)+  -> FreeT f m a+  -> t m a iterTM f (FreeT m) = do-    val <- lift m-    case val of-        Pure x -> return x-        Free y k -> f $ fmap (iterTM f . runKleisli (qApp k)) y+  val <- lift m+  case val of+    Pure x   -> return x+    Free y k -> f $ fmap (iterTM f . runKleisli (qApp k)) y  -- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@ -- -- @'hoistFreeT' :: ('Monad' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@-hoistFreeT :: (Monad m, Applicative f)-           => (forall a. m a -> n a)-           -> FreeT f m b-           -> FreeT f n b-hoistFreeT mh = FreeT . mh . fmap f . runFreeT where-  f (Pure a) = Pure a+hoistFreeT+  :: (Monad m, Applicative f)+  => (forall a . m a -> n a)+  -> FreeT f m b+  -> FreeT f n b+hoistFreeT mh = FreeT . mh . fmap f . runFreeT+ where+  f (Pure a  ) = Pure a   f (Free b k) = Free b $ tmap (Kleisli . (hoistFreeT mh .) . runKleisli) k  -- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@-transFreeT :: (Applicative f, Monad m)-           => (forall a. f a -> g a)-           -> FreeT f m b-           -> FreeT g m b+transFreeT+  :: (Applicative f, Monad m)+  => (forall a . f a -> g a)+  -> FreeT f m b+  -> FreeT g m b transFreeT nt = FreeT . fmap (transFreeF nt) . runFreeT  -- | Pull out and join @m@ layers of @'FreeT' f m a@.-joinFreeT :: forall m f a. ( Monad m-                           , Traversable f-                           , Applicative f)-                           => FreeT f m a -> m (Free f a)+joinFreeT+  :: forall m f a+   . (Monad m, Traversable f, Applicative f)+  => FreeT f m a+  -> m (Free f a) joinFreeT (FreeT m) = m >>= joinFreeF-  where-    joinFreeF :: FreeF f m a -> m (Free f a)-    joinFreeF (Pure x) = return (return x)-    joinFreeF (Free y ks) = wrap <$> mapM (joinFreeT . runKleisli (qApp ks)) y+ where+  joinFreeF :: FreeF f m a -> m (Free f a)+  joinFreeF (Pure x   ) = return (return x)+  joinFreeF (Free y ks) = wrap <$> mapM (joinFreeT . runKleisli (qApp ks)) y  -- | Tear down a free monad transformer using Monad instance for @t m@. retractT :: (MonadTrans t, Monad (t m), Monad m) => FreeT (t m) m a -> t m a retractT (FreeT m) = do   val <- lift m   case val of-    Pure x -> return x+    Pure x   -> return x     Free y k -> y >>= retractT . runKleisli (qApp k)  -- | The \"free monad\" for an applicative functor @f@.@@ -272,10 +277,9 @@ -- 'retract' . 'liftF' = 'id' -- @ retract :: Monad f => Free f a -> f a-retract m =-  case runIdentity (runFreeT m) of-    Pure a  -> return a-    Free x ks -> x >>= retract . runKleisli (qApp ks)+retract m = case runIdentity (runFreeT m) of+  Pure a    -> return a+  Free x ks -> x >>= retract . runKleisli (qApp ks)  -- | Tear down a 'Free' 'Monad' using iteration. iter :: Applicative f => (f a -> a) -> Free f a -> a
tests/ExampleDataSource.hs view
@@ -5,13 +5,16 @@ {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE StandaloneDeriving         #-} -module ExampleDataSource (+module ExampleDataSource+  (     -- * requests for this data source-    Id(..), ExampleReq(..)+    Id(..)+  , ExampleReq(..)   , fetchExample   , countAardvarks   , listWombats-  ) where+  )+where  import           Control.Monad.Fraxl @@ -64,8 +67,10 @@  fetchExample :: Monad m => Fetch ExampleReq m a fetchExample ANil = return ANil-fetchExample (ACons (CountAardvarks str) rs) = ACons <$> return (return (length (filter (== 'a') str))) <*> fetchExample rs-fetchExample (ACons (ListWombats a) rs) = ACons <$> return (return (take (fromIntegral a) [1..])) <*> fetchExample rs+fetchExample (ACons (CountAardvarks str) rs) =+  ACons <$> return (return (length (filter (== 'a') str))) <*> fetchExample rs+fetchExample (ACons (ListWombats a) rs) =+  ACons <$> return (return (take (fromIntegral a) [1 ..])) <*> fetchExample rs  countAardvarks :: MonadFraxl ExampleReq m => String -> m Int countAardvarks str = dataFetch (CountAardvarks str)
tests/MonadBench.hs view
@@ -3,46 +3,49 @@  module Main where -import ExampleDataSource-import Control.Monad.Fraxl-import Control.Monad-import Data.Time.Clock-import System.Environment-import System.Exit-import System.IO-import Text.Printf+import           ExampleDataSource+import           Control.Monad.Fraxl+import           Control.Monad+import           Data.Time.Clock+import           System.Environment+import           System.Exit+import           System.IO+import           Text.Printf  main :: IO () main = do-    [test,n_] <- getArgs-    let n = read n_-    t0 <- getCurrentTime-    case test of-      -- parallel, identical queries-      "par1" -> evalCachedFraxl (fetchExample |:| fetchNil) $-        void $ sequenceA (replicate n (listWombats 3 :: Fraxl '[ExampleReq] IO [Id]))-      -- parallel, distinct queries-      "par2" -> evalCachedFraxl (fetchExample |:| fetchNil) $-        void $ sequenceA (map listWombats [1..fromIntegral n] :: [Fraxl '[ExampleReq] IO [Id]])-      -- sequential, identical queries-      "seqr" -> evalCachedFraxl (fetchExample |:| fetchNil) $-        foldr andThen (return ()) (replicate n (listWombats 3 :: Fraxl '[ExampleReq] IO [Id]))-      -- sequential, left-associated, distinct queries-      "seql" -> evalCachedFraxl (fetchExample |:| fetchNil) $-        void $ foldl andThen (return []) (map listWombats [1.. fromIntegral n] :: [Fraxl '[ExampleReq] IO [Id]])-      "tree" -> evalCachedFraxl (fetchExample |:| fetchNil) $ void (tree n :: Fraxl '[ExampleReq] IO [Id])-      _ -> do-        hPutStrLn stderr "syntax: monadbench par1|par2|seqr|seql NUM"-        exitWith (ExitFailure 1)-    t1 <- getCurrentTime-    printf "%d reqs: %.2fs\n" n (realToFrac (t1 `diffUTCTime` t0) :: Double)+  [test, n_] <- getArgs+  let n = read n_+  t0 <- getCurrentTime+  case test of+    -- parallel, identical queries+    "par1" -> evalCachedFraxl (fetchExample |:| fetchNil) $ void $ sequenceA+      (replicate n (listWombats 3 :: Fraxl '[ExampleReq] IO [Id]))+    -- parallel, distinct queries+    "par2" -> evalCachedFraxl (fetchExample |:| fetchNil) $ void $ sequenceA+      (map listWombats [1 .. fromIntegral n] :: [Fraxl '[ExampleReq] IO [Id]])+    -- sequential, identical queries+    "seqr" -> evalCachedFraxl (fetchExample |:| fetchNil) $ foldr+      andThen+      (return ())+      (replicate n (listWombats 3 :: Fraxl '[ExampleReq] IO [Id]))+    -- sequential, left-associated, distinct queries+    "seql" -> evalCachedFraxl (fetchExample |:| fetchNil) $ void $ foldl+      andThen+      (return [])+      (map listWombats [1 .. fromIntegral n] :: [Fraxl '[ExampleReq] IO [Id]])+    "tree" -> evalCachedFraxl (fetchExample |:| fetchNil)+      $ void (tree n :: Fraxl '[ExampleReq] IO [Id])+    _ -> do+      hPutStrLn stderr "syntax: monadbench par1|par2|seqr|seql NUM"+      exitWith (ExitFailure 1)+  t1 <- getCurrentTime+  printf "%d reqs: %.2fs\n" n (realToFrac (t1 `diffUTCTime` t0) :: Double)   where     -- can't use >>, it is aliased to *> and we want the real bind here-    andThen x y = x >>= const y+        andThen x y = x >>= const y  tree :: MonadFraxl ExampleReq m => Int -> m [Id] tree 0 = listWombats 0-tree n = concat <$> sequenceA-  [ tree (n-1)-  , listWombats (fromIntegral n), tree (n-1)-  ]+tree n = concat+  <$> sequenceA [tree (n - 1), listWombats (fromIntegral n), tree (n - 1)]