packages feed

fraxl (empty) → 0.1.0.0

raw patch · 12 files changed

+1113/−0 lines, 12 filesdep +asyncdep +basedep +dependent-mapsetup-changed

Dependencies added: async, base, dependent-map, dependent-sum, exceptions, fraxl, free, mtl, time, transformers, type-aligned, vinyl-plus

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Will Fancher (c) 2016++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 Will Fancher 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.
+ README.md view
@@ -0,0 +1,108 @@+Fraxl+---++[Documentation](http://elvishjerricco.github.io/fraxl/fraxl-0.1.0.0/)++Fraxl is a library based on Facebook's [Haxl](https://github.com/facebook/Haxl).+The goal is to decompose Haxl into more general parts,+in order to form a stronger composition with better type safety and purity.++Usage+---++Using Fraxl is fairly similar to Haxl.+You define a request data type (often a GADT), and a `Fetch` function.+With this, Fraxl is able to perform requests concurrently.++```haskell+data MySource a where+  MyString :: MySource String+  MyInt :: MySource Int++type Fetch f m a = ASeq f a -> m (ASeq m a)++fetchMySource :: MonadIO m => Fetch MySource m a+fetchMySource ANil = return ANil+fetchMySource (ACons f fs) = (ACons. liftIO . wait)+  <$> liftIO (async $ downloadSource f)+  <*> fetchMySource fs++> let a = ...+> runFraxl fetchMySource a++```++You'll notice a few things here.+For one, a data source can choose what monad it lives in.+Unlike Haxl, which only lets you live in `IO`,+Fraxl is a monad transformer, allowing you to use arbitrary underlying monads.+Thus, maintaining state between fetches can be left up to the data source.+This can be used for several things, such as caching or session management.++Unlike Haxl, a data source isn't tied to one fetch function.+Haxl requires your data source to implement the `DataSource` class.+By passing a `Fetch` function to Fraxl,+it's easy to have multiple interpretations of the same data source.+This is useful for mocking and testing data sources.++`ASeq :: (* -> *) -> * -> *` is similar to a heterogenous list.+It is the data structure used by the fast free applicative.+Interpreting this is akin to interpreting the free applicative.++The `Fetch` function takes a list of `f` requests,+and for each request, returns an `m` action that waits on the response.+That is, `fetch` should start background threads for requests,+and return all the actions for Fraxl to block with until they complete.+This way, Fraxl can have many requests start their work in parallel,+and call all their wait-actions together.++Composition+---++Fraxl is a composition of general tools.+At the base of this composition is a free monad transformer+([the basis of which is described here](http://elvishjerricco.github.io/2016/04/08/applicative-effects-in-free-monads.html)).+This is because Fraxl (and Haxl) is necessarily a free monad.+It's taking arbitrary data sources of kind `* -> *`,+and constructing a monad out of them.+Since there exists a free monad transformer with applicative optimization,+there's no reason not to use it and get the transformer structure for free.++The next layer of the composition is the free applicative.+The free monad with applicative optimization uses any applicative+(rather than any functor, as with the traditional free monad).+Since the free applicative uses any type of kind `* -> *`,+it is the perfect candidate for this layer.+It allows Fraxl to see all the requests made in+an applicative computation at once, which is how Fraxl can parallelize them.++The final layer is the data source layer.+It is user-specified, but will often be a `Union :: [* -> *] -> * -> *`.+The union is essentially a nested either type+over any number of type constructors.++```+Union '[f, g, h] a ≡ Either (f a) (Either (g a) (h a))+```++If all of those types are data sources, the union allows+Fraxl to handle all of them as one data source, in one layer of Fraxl.+The nice thing about this is that it makes it type safe to use a data source.+Whereas Haxl will simply trust that you know what you're doing,+Fraxl will make it a type error to forget to initialize a data source,+or call a computation without guaranteeing its data source is available.++The data source layer can be easily modified.+Caching is a substitution of this layer that replaces the data+source with one that caches the results of the original.+It does this with a dependent map, whose keys are requests,+and whose values are `MVars` of the results.+If an uncached request is requested,+an empty `MVar` is inserted into the cache map, the original `fetch` is called,+and the result is stored in the `MVar`.+If a cached request is requested,+the wait-action returned will simply be `readMVar`.++---++Check out [the example](examples/src/Main.hs) for a demonstration.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/src/Main.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances  #-}++module Main where++import           Control.Concurrent+import           Control.Monad.Fraxl+import           Control.Monad.IO.Class+import           Control.Monad.State++main :: IO ()+main = do+  let fraxl = (++) <$> myFraxl <*> myFraxl+  (strs, reqs) <- runStateT (evalCachedFraxl (fetchMySource |:| fetchMySource2 |:| fetchNil) fraxl) 0+  putStrLn ("Number of MySource2 requests made: " ++ show reqs)+  print $ length strs+  print strs++myFraxl :: (MonadFraxl MySource m, MonadFraxl MySource2 m) => m [String]+myFraxl = replicate <$> myInt2 <*> myString++data MySource a where+  MyString :: MySource String+  MyInt :: MySource Int++instance GEq MySource where+  MyString `geq` MyString = Just Refl+  MyInt `geq` MyInt = Just Refl+  _ `geq` _ = Nothing++instance GCompare MySource where+  MyString `gcompare` MyString = GEQ+  MyString `gcompare` MyInt = GLT+  MyInt `gcompare` MyString = GGT+  MyInt `gcompare` MyInt = GEQ++fetchMySource :: MonadIO m => Fetch MySource m a+fetchMySource = simpleAsyncFetch simpleFetch where+  simpleFetch :: MySource a -> IO a+  simpleFetch MyString = do+    putStrLn "Sleeping String!"+    threadDelay 1000000+    return "String!"+  simpleFetch MyInt = do+    putStrLn "Sleeping Int!"+    threadDelay 1000000+    return 10++myString :: MonadFraxl MySource m => m String+myString = dataFetch MyString++myInt :: MonadFraxl MySource m => m Int+myInt = dataFetch MyInt++data MySource2 a where+  MyString2 :: MySource2 String+  MyInt2 :: MySource2 Int++instance GEq MySource2 where+  MyString2 `geq` MyString2 = Just Refl+  MyInt2 `geq` MyInt2 = Just Refl+  _ `geq` _ = Nothing++instance GCompare MySource2 where+  MyString2 `gcompare` MyString2 = GEQ+  MyString2 `gcompare` MyInt2 = GLT+  MyInt2 `gcompare` MyString2 = GGT+  MyInt2 `gcompare` MyInt2 = GEQ++fetchMySource2 :: (MonadIO m, MonadState Int m) => Fetch MySource2 m a+fetchMySource2 a = modify (+ clength a) >> simpleAsyncFetch simpleFetch a where+  clength :: ASeq f r -> Int+  clength ANil = 0+  clength (ACons _ rs) = 1 + clength rs+  simpleFetch :: MySource2 a -> IO a+  simpleFetch MyString2 = do+    putStrLn "Sleeping String2!"+    threadDelay 1000000+    return "String!"+  simpleFetch MyInt2 = do+    putStrLn "Sleeping Int2!"+    threadDelay 1000000+    return 10++myString2 :: MonadFraxl MySource2 m => m String+myString2 = dataFetch MyString2++myInt2 :: MonadFraxl MySource2 m => m Int+myInt2 = dataFetch MyInt2
+ fraxl.cabal view
@@ -0,0 +1,69 @@+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++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++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++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
+ src/Control/Applicative/Fraxl/Free.hs view
@@ -0,0 +1,108 @@+{-# 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
@@ -0,0 +1,29 @@+module Control.Monad.Fraxl+  (+  -- * The Fraxl Monad+    FreerT+  , Fraxl+  , Fetch+  , runFraxl+  , simpleAsyncFetch+  , fetchNil+  , (|:|)+  -- * The Sequence of Effects+  , ASeq(..)+  , reduceASeq+  , hoistASeq+  , traverseASeq+  , rebaseASeq+  -- * Caching+  , CachedFetch(..)+  , fetchCached+  , runCachedFraxl+  , evalCachedFraxl+  , module Data.GADT.Compare+  -- * Fraxl Monads+  , MonadFraxl(..)+  ) where++import           Control.Monad.Fraxl.Class+import           Control.Monad.Trans.Fraxl+import           Data.GADT.Compare
+ src/Control/Monad/Fraxl/Class.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DefaultSignatures     #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators         #-}+-- Not actually undecidable.+-- @MonadFraxl f (Fraxl r m)@ is not undecidable,+-- but @f ∈ r@ doesn't satisfy the functional dependency @Fraxl r m -> f@.+{-# LANGUAGE UndecidableInstances  #-}++module Control.Monad.Fraxl.Class+ (+ -- * Fraxl Monads+   MonadFraxl(..)+ ) where++import           Control.Applicative.Fraxl.Free+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++-- | 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+  dataFetch = lift . dataFetch++instance (Monad m, f ∈ r) => MonadFraxl f (Fraxl r m) where+  dataFetch = liftF . liftAp . Union . FunctorCoRec . CR.lift . Flap++instance Monad m => MonadFraxl f (FreerT f m) where+  dataFetch = liftF . liftAp++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+instance (MonadFraxl f m, Monoid w) => MonadFraxl f (Strict.RWST r w s m) where+instance MonadFraxl f m => MonadFraxl f (Lazy.StateT s m) where+instance MonadFraxl f m => MonadFraxl f (Strict.StateT s m) where+instance (MonadFraxl f m, Monoid w) => MonadFraxl f (Lazy.WriterT w m) where+instance (MonadFraxl f m, Monoid w) => MonadFraxl f (Strict.WriterT w m) where
+ src/Control/Monad/Trans/Fraxl.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeOperators         #-}++module Control.Monad.Trans.Fraxl+  (+  -- * The Fraxl Monad+    FreerT+  , Fraxl+  , Fetch+  , runFraxl+  , simpleAsyncFetch+  , fetchNil+  , (|:|)+  , hoistFetch+  , transFetch+  -- * The Sequence of Effects+  , ASeq(..)+  , reduceASeq+  , hoistASeq+  , traverseASeq+  , rebaseASeq+  -- * Caching+  , CachedFetch(..)+  , fetchCached+  , runCachedFraxl+  , evalCachedFraxl+  , module Data.GADT.Compare+  -- * Union+  , Union(..)+  , getCoRec+  , mkUnion+  ) where++import           Control.Applicative.Fraxl.Free+import           Control.Arrow+import           Control.Concurrent+import           Control.Concurrent.Async+import           Control.Monad+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.GADT.Compare+import qualified Data.Vinyl.Prelude.CoRec       as CR+import           Data.Vinyl.Types++-- | Fraxl is based on a particular Freer monad.+-- This Freer monad has applicative optimization,+-- which is used to parallelize effects.+type FreerT f = FreeT (Ap f)++-- | Fraxl is just the 'FreerT' monad transformer, applied with 'Union'.+-- This is because 'Fraxl' is just a free monad over a variety of data sources.+type Fraxl r = FreerT (Union r)++-- | A data source is an effect @f@ that operates in some monad @m@.+-- Given a sequence of effects,+-- a data source should use @m@ to prepare a corresponding sequence of results.+type Fetch f m a = ASeq f a -> m (ASeq m a)++-- | Fetch empty union.+-- Only necessary to terminate a list of 'Fetch' functions for @Fetch (Union r)@+fetchNil :: Applicative m => Fetch (Union '[]) m a+fetchNil ANil = pure ANil+fetchNil _ = error "Not possible - empty union"++-- | Like '(:)' for constructing @Fetch (Union (f ': r))@+(|:|) :: forall f r a m. Monad m+       => (forall a'. Fetch f m a')+       -> (forall a'. Fetch (Union r) m a')+       -> Fetch (Union (f ': r)) m a+(fetch |:| fetchU) list = (\(_, _, x) -> x) <$> runUnion ANil ANil list where+  runUnion :: ASeq f x+           -> ASeq (Union r) y+           -> 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+    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)++infixr 5 |:|++-- | Hoist a 'Fetch' function into a different result monad.+hoistFetch :: Functor m => (forall x. m x -> n x) -> Fetch f m a -> Fetch f n a+hoistFetch u f = u . fmap (hoistASeq u) . f++-- | Translate a 'Fetch' function from @f@ requests, to @g@ requests.+transFetch :: (forall x. g x -> f x) -> Fetch f m a -> Fetch g m a+transFetch u f list = f (hoistASeq u list)++-- | Runs a Fraxl computation, using a given 'Fetch' function for @f@.+-- This takes 'FreerT' as a parameter rather than 'Fraxl',+-- because 'Fraxl' is meant for a union of effects,+-- but it should be possible to run a singleton effect.+runFraxl :: Monad m => (forall a'. Fetch f m a') -> FreerT f m a -> m a+runFraxl fetch = iterT $ \a -> unAp a+  (\f s -> join (reduceASeq <$> fetch s) >>= f) (const id) ANil++-- | A simple method of turning an 'IO' bound computation+-- into a concurrent 'Fetch'.+simpleAsyncFetch :: MonadIO m+                    => (forall x. f x -> IO x)+                    -> Fetch f m a+simpleAsyncFetch fetchIO+  = traverseASeq (fmap (liftIO . wait) . liftIO . async . fetchIO)++-- | Caching in Fraxl works by translating @FreerT f@ into+-- @FreerT (CachedFetch f)@, then running with 'CachedFetch''s DataSource.+-- That instance requires 'f' to to have a 'GCompare' instance.+--+-- The 'CachedFetch' instance uses a 'MonadState' to track cached requests.+-- The state variable is a 'DMap' from the 'dependent-map' package.+-- Keys are requests, and values are 'MVar's of the results.+newtype CachedFetch f a = CachedFetch (f a)++fetchCached :: forall t m f a.+            ( Monad m+            , MonadTrans t+            , MonadState (DMap f MVar) (t m)+            , GCompare f+            , MonadIO (t m))+            => (forall a'. Fetch f m a') -> Fetch (CachedFetch f) (t m) a+fetchCached fetch list = snd <$> runCached ANil list where+  runCached :: ASeq f x+            -> ASeq (CachedFetch f) y+            -> t m (ASeq (t m) x, ASeq (t m) y)+  runCached flist ANil = (, ANil) <$> lift (hoistASeq lift <$> fetch flist)+  runCached flist (ACons (CachedFetch f) fs) = do+    cache <- get+    case DMap.lookup f cache of+      Just mvar -> fmap+        (second (ACons (liftIO $ readMVar mvar)))+        (runCached flist fs)+      Nothing -> do+        (mvar :: MVar z) <- liftIO newEmptyMVar+        put (DMap.insert f mvar cache)+        let store :: t m z -> t m z+            store m = m >>= \a -> liftIO (putMVar mvar a) >> return a+        fmap+          (\(ACons m ms, rest) -> (ms, ACons (store m) rest))+          (runCached (ACons f flist) fs)++-- | Runs a Fraxl computation with caching using a given starting cache.+-- Alongside the result, it returns the final cache.+runCachedFraxl :: forall m f a.+                  ( MonadIO m+                  , GCompare f)+                  => (forall a'. Fetch f m a')+                  -> FreerT f m a+                  -> DMap f MVar+                  -> m (a, DMap f MVar)+runCachedFraxl fetch a cache = let+  cachedA :: FreerT (CachedFetch f) (StateT (DMap f MVar) m) a+  cachedA = transFreeT (hoistAp CachedFetch) (hoistFreeT lift a)+  in runStateT (runFraxl (fetchCached fetch) cachedA) cache++-- | Like 'runCachedFraxl', except it starts with an empty cache+-- and discards the final cache.+evalCachedFraxl :: forall m f a.+                   ( MonadIO m+                   , GCompare f)+                   => (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)++getCoRec :: Union r a -> CoRec (Flap a) r+getCoRec (Union (FunctorCoRec u)) = u++mkUnion :: CoRec (Flap a) r -> Union r a+mkUnion u = Union $ FunctorCoRec u++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+    (Left (Flap fa), Left (Flap fb)) -> fa `geq` fb+    (Right a', Right b') -> mkUnion a' `geq` mkUnion 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+    (Left (Flap fa), Left (Flap fb)) -> fa `gcompare` fb+    (Right a', Right b')             -> mkUnion a' `gcompare` mkUnion b'+    (Left _, Right _)                -> GLT+    (Right _, Left _)                -> GGT
+ src/Control/Monad/Trans/Fraxl/Free.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE UndecidableInstances  #-}++module Control.Monad.Trans.Fraxl.Free+  (+  -- * The base functor+    FreeF(..)+  -- * The free monad transformer+  , FreeT(..)+  -- * The free monad+  , Free+  -- * Operations+  , liftF+  , iterT+  , iterTM+  , hoistFreeT+  , transFreeT+  , joinFreeT+  , retractT+  -- * Operations of free monad+  , retract+  , iter+  , iterM+  -- * Free Monads With Class+  , MonadFree(..)+  ) where++import           Control.Applicative+import           Control.Arrow+import           Control.Monad+import           Control.Monad.Catch+import           Control.Monad.Cont.Class+import           Control.Monad.Error.Class+import           Control.Monad.Free.Class+import           Control.Monad.IO.Class+import           Control.Monad.Reader.Class+import           Control.Monad.State.Class+import           Control.Monad.Trans+import           Control.Monad.Writer.Class+import           Data.Functor.Identity+import           Data.Monoid+import           Data.TASequence.FastCatQueue++-- Commented here is the simplest definition of this version of the Free monad.+-- It's a freer monad relying on Applicative for optimization.+--------------------------------------------------------------------------------+-- data Free f a where+--   Pure :: a -> Free f a+--   Impure :: f a -> (a -> Free f b) -> Free f b+--+-- instance Functor (Free f) where+--   fmap f (Pure a) = Pure (f a)+--   fmap f (Impure a k) = Impure a (fmap f . k)+--+-- instance Applicative f => Applicative (Free f) where+--   pure = Pure+--   Pure f <*> a = fmap f a+--   Impure x k <*> Pure a = Impure x (fmap ($ a) . k)+--   Impure x k <*> Impure y k' = Impure (fmap ((<*>) . k) x <*> fmap k' y) id+--+-- instance Applicative f => Monad (Free f) where+--   Pure a >>= k = k a+--   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+(>.<) f arrs = case tviewr arrs of+  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 arrs = case tviewl arrs of+  TAEmptyL -> Kleisli pure+  k :< ks -> k >>> qApp ks++-- | The base functor for a free monad.+data FreeF f m a where+  Pure :: a -> FreeF f m a+  Free :: f b -> FastTCQueue (Kleisli (FreeT f m)) b a -> FreeF f m a+instance (Applicative f, Monad m) => Functor (FreeF f m) where+  fmap f (Pure a)  = Pure (f a)+  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+{-# INLINE transFreeF #-}++-- | The \"free monad transformer\" for an applicative functor @f@+newtype FreeT f m a = FreeT { runFreeT :: m (FreeF f m a) }++instance (Applicative f, Monad m) => Functor (FreeT f m) where+  fmap f (FreeT m) = FreeT $ fmap (fmap f) m+  {-# INLINE fmap #-}++-- Applicative 'pure' but with no @Applicative f@ constraint+freePure :: Applicative m => a -> FreeT f m a+freePure = FreeT . pure . Pure+{-# INLINE freePure #-}++instance (Applicative f, Monad m) => Applicative (FreeT f m) where+  pure = freePure+  {-# INLINE pure #-}+  FreeT f <*> FreeT a = FreeT $ g <$> f <*> a where+    g :: FreeF f m (a -> b) -> FreeF f m a -> FreeF f m b+    g (Pure f') a' = fmap f' a'+    g (Free b kf) (Pure a') = Free b (fmap ($ a') >.< kf)+    g (Free b kf) (Free c ka) = Free (f' <$> b <*> c) (tsingleton (Kleisli id))+      where f' b' c' = runKleisli (qApp kf) b' <*> runKleisli (qApp ka) c'+  {-# INLINE (<*>) #-}++instance (Applicative f, Monad m) => Monad (FreeT f m) where+  FreeT ma >>= k = FreeT $ do+    freef <- ma+    case freef of+      Pure a -> runFreeT (k a)+      Free b k' -> return $ Free b (k' |> Kleisli k)+  {-# INLINE (>>=) #-}++instance MonadTrans (FreeT f) where+  lift = FreeT . fmap Pure++instance (Applicative f, Monad m) => MonadFree f (FreeT f m) where+  wrap = FreeT . return . flip Free (tsingleton $ Kleisli id)+  {-# INLINE wrap #-}++instance (Applicative f, MonadIO m) => MonadIO (FreeT f m) where+  liftIO = lift . liftIO+  {-# INLINE liftIO #-}++instance (Applicative f, MonadReader r m) => MonadReader r (FreeT f m) where+  ask = lift ask+  {-# INLINE ask #-}+  local f = hoistFreeT (local f)+  {-# INLINE local #-}++instance (Applicative f, MonadWriter w m) => MonadWriter w (FreeT f m) where+  tell = lift . tell+  {-# INLINE tell #-}+  listen (FreeT m) = FreeT $ concat' <$> listen (relisten <$> m)+    where+      relisten (Pure a) = Pure (a, mempty)+      relisten (Free y ks) = Free y (listen >.< ks)+      concat' (Pure (x, w1), w2) = Pure (x, w1 <> w2)+      concat' (Free x ks, w) = Free x $ fmap (second (w <>)) >.< ks+  pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m+    where+      clean = pass . fmap (\x -> (x, const mempty))+      pass' = join . fmap g+      g (Pure ((x, f), w)) = tell (f w) >> return (Pure x)+      g (Free x ks)        = return $ Free x $ (FreeT . pass' . runFreeT) >.< ks+  writer w = lift (writer w)+  {-# INLINE writer #-}++instance (Applicative f, MonadState s m) => MonadState s (FreeT f m) where+  get = lift get+  {-# INLINE get #-}+  put = lift . put+  {-# INLINE put #-}+  state f = lift (state f)+  {-# INLINE state #-}++instance (Applicative f, MonadError e m) => MonadError e (FreeT f m) where+  throwError = lift . throwError+  {-# INLINE throwError #-}+  FreeT m `catchError` f = FreeT $ fmap recatch m `catchError` (runFreeT . f)+    where recatch (Pure x) = Pure x+          recatch (Free x ks) = Free x $ (`catchError` f) >.< ks++instance (Applicative f, MonadCont m) => MonadCont (FreeT f m) where+  callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure))++instance (Applicative f, MonadPlus m) => Alternative (FreeT f m) where+  empty = FreeT mzero+  FreeT ma <|> FreeT mb = FreeT (mplus ma mb)+  {-# INLINE (<|>) #-}++instance (Applicative f, MonadPlus m) => MonadPlus (FreeT f m) where+  mzero = FreeT mzero+  {-# INLINE mzero #-}+  mplus (FreeT ma) (FreeT mb) = FreeT (mplus ma mb)+  {-# INLINE mplus #-}++instance (Applicative f, MonadThrow m) => MonadThrow (FreeT f m) where+  throwM = lift . throwM+  {-# INLINE throwM #-}++instance (Applicative f, MonadCatch m) => MonadCatch (FreeT f m) where+  FreeT m `catch` f = FreeT $ fmap recatch m `catch` (runFreeT . f)+    where recatch (Pure x) = Pure x+          recatch (Free x ks) = Free x $ (`catch` f) >.< ks+  {-# INLINE catch #-}++-- | 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++-- | 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 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++-- | 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+  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 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 (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++-- | 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+    Free y k -> y >>= retractT . runKleisli (qApp k)++-- | The \"free monad\" for an applicative functor @f@.+type Free f = FreeT f Identity++-- |+-- 'retract' is the left inverse of 'liftF'+--+-- @+-- '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)++-- | Tear down a 'Free' 'Monad' using iteration.+iter :: Applicative f => (f a -> a) -> Free f a -> a+iter phi = runIdentity . iterT (Identity . phi . fmap runIdentity)++-- | Like 'iter' for monadic values.+iterM :: (Applicative f, Monad m) => (f (m a) -> m a) -> Free f a -> m a+iterM phi = iterT phi . hoistFreeT (return . runIdentity)
+ tests/ExampleDataSource.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE StandaloneDeriving         #-}++module ExampleDataSource (+    -- * requests for this data source+    Id(..), ExampleReq(..)+  , fetchExample+  , countAardvarks+  , listWombats+  ) where++import           Control.Monad.Fraxl++-- Here is an example minimal data source.  Our data source will have+-- two requests:+--+--   countAardvarks :: String -> Haxl Int+--   listWombats    :: Id     -> Haxl [Id]+--+-- First, the data source defines a request type, with one constructor+-- for each request:++newtype Id = Id Int+  deriving (Eq, Ord, Enum, Num, Integral, Real)++instance Show Id where+  show (Id i) = show i++data ExampleReq a where+  CountAardvarks :: String -> ExampleReq Int+  ListWombats    :: Id     -> ExampleReq [Id]++-- The request type (ExampleReq) is parameterized by the result type of+-- each request.  Each request might have a different result, so we use a+-- GADT - a data type in which each constructor may have different type+-- parameters. Here CountAardvarks is a request that takes a String+-- argument and its result is Int, whereas ListWombats takes an Id+-- argument and returns a [Id].++deriving instance Show (ExampleReq a)++instance GEq ExampleReq where+  CountAardvarks _ `geq` CountAardvarks _ = Just Refl+  ListWombats _ `geq` ListWombats _ = Just Refl+  _ `geq` _ = Nothing++instance GCompare ExampleReq where+  CountAardvarks a `gcompare` CountAardvarks b = case a `compare` b of+    EQ -> GEQ+    LT -> GLT+    GT -> GGT+  ListWombats a `gcompare` ListWombats b = case a `compare` b of+    EQ -> GEQ+    LT -> GLT+    GT -> GGT+  CountAardvarks _ `gcompare` ListWombats _ = GLT+  ListWombats _ `gcompare` CountAardvarks _ = GGT++-- We need to define an instance of DataSource:++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++countAardvarks :: MonadFraxl ExampleReq m => String -> m Int+countAardvarks str = dataFetch (CountAardvarks str)++listWombats :: MonadFraxl ExampleReq m => Id -> m [Id]+listWombats a = dataFetch (ListWombats a)
+ tests/MonadBench.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}++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++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)+  where+    -- can't use >>, it is aliased to *> and we want the real bind here+    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)+  ]