packages feed

supply-chain-core (empty) → 0.0.0.0

raw patch · 15 files changed

+745/−0 lines, 15 filesdep +basedep +supply-chain-coredep +tasty

Dependencies added: base, supply-chain-core, tasty, tasty-hedgehog, tasty-hunit

Files

+ changelog.md view
@@ -0,0 +1,3 @@+# 0.0.0.0 (2022-11-08)++* Initial release
+ license.txt view
@@ -0,0 +1,13 @@+Copyright 2022 Mission Valley Software LLC++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++    http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ readme.md view
@@ -0,0 +1,157 @@+## Story++The initial idea for this library stemmed from the [pipes] library. The+interfaces of a pipes [Proxy] are given by four types: What the proxy sends+upstream, receives from upstream, sends downstream, and receives from+downstream. A value of type `Proxy a' a b' b m r` is depicted in the pipes+documentation as follows:++```+Upstream | Downstream+    +---------++    |         |+a' <==       <== b'+    |         |+a  ==>       ==> b+    |    |    |+    +----|----++         v+         r+```++A pipes server (focusing on downstream side) can accept exactly one of request+(`b'`) and issue exactly one type of response (`b`). The response type cannot+vary based on what type of request it is responding to.++When interfaces are described by a *type constructor* rather than a pair of+types, then we can pair types of requests with appropriate responses. I first+saw this approach in the [haxl] library. The [Facebook example] in haxl's+documentation gives this example of what it calls a "data source API":++```haskell+data FacebookReq response =+     (response ~ Object)   => GetObject Id+   | (response ~ User)     => GetUser UserId+   | (response ~ [Friend]) => GetUserFriends UserId+```++The kind of `FacebookReq` is `Type -> Type`. The phantom type variable+`response` here indicates what type of response a data source must give in+response to a `FacebookReq response`. For example, the `GetUser` constructor+produces a request of type `FacebookReq User`, and so the data source returns a+value of type `User`.++This pattern can also be found in the [effectful] library, where a similar sort+of type constructor is called a "dynamic effect". To take just one example of a+dynamic effect that the library offers, its [dynamic State effect] (analogous to+[StateT] of the [transformers] library) is defined as follows:++```haskell+data State s m response =+      (response ~ s)  => Get+    | (response ~ ()) => Put s+    | (response ~ a)  => State (s -> (a, s))+    | (response ~ a)  => StateM (s -> m (a, s))+```++The kind of `State s m` is, again, `Type -> Type`, and a constraint on each+constructor specifies what type of corresponding response is expected.++Let us return our attention to the pipes [Proxy] type. When we attempt to alter+`Proxy` to employ the type constructor interface style as discussed in the+previous two examples, it becomes apparent that much of the generality and+symmetry that the pipes library enjoys must be sacrificed. Our library has only+"pull" streams, in which a vendor's action is always a response to a downstream+request. Pipes discusses "push" streams, in which upstream actors may take+initiative, and we offer nothing of the sort.++Also unlike pipes, we have separate `Vendor` and `Job` types, whereas pipes+unifies upstream and downstream ideas into a single type called `Proxy`, of+which `Producer` and `Consumer` are merely aliases with a few of the type+parameters fixed. Although we have opted not to to so, it would be possible for+supply-chain to mimic the pipes design, observing that `loop` and `once`+demonstrate an isomorphism between `Vendor up (Unit product) action` and+`Job up action product` and that would permit unifying `Vendor` and `Job` in+the pipes style.++```haskell+loop :: Job up action product -> Vendor up (Unit product) action+once :: Vendor up (Unit product) action -> Job up action product+```++This approach is tempting chiefly because it permits a single connection+operator (which pipes calls `>->`) where supply-chain has two (`>->` and `>-`).+But in our library, this unification appears to cause more problems than it+solves, and type aliases in general tend to result in poor developer+experiences.++I also explored the possibility of defining a pipes-like unified `>->` operator+as a multi-parameter typeclass method, with one instance for vendor-to-vendor+connection and another for vendor-to-job connection. This can be made to work,+and with the help of [functional dependencies] can even lend itself to+sufficient type inference despite a large number of type parameters involved. In+practice, however, the complication that the polymorphism introduces to type+errors and typed hole feedback outweighs the benefit of an overloaded connection+operator.++Another difference between supply-chain and pipes is that `Vendor` cannot+return. The ability of a `Producer` or `Pipe` to return is a point of difficulty+for me as a pipes user, because in a pipes chain `a >-> b >-> c` very rarely is+there any reason why `a` or `b` would ever return and "shut the pipeline down+early". The advantage of this approach in pipes is that it allows `Producer`+(being simply an alias for `Proxy`) to be monad, whereas to define a `Vendor`+one must take the additional step of applying the `Vendor` constructor to a+function whose actual monadic context is `Job`. The advantage of the+supply-chain approach is that the type signatures for vendors are not burdened+with an irrelevant type parameter representing the return type of something that+will never actually return.++The influence of the [effectful] library, in spirit if not manifest in any+concrete technique, deserves remark. A job's upstream interface and action+context correspond to what the effectful library calls "dynamic effects" and+"static effects" respectively. Our `(>-)` function corresponds roughly to what+effectful describes as "reinterpeting" the job's upstream interface.++What effectful has that supply-chain lacks is its mechanism for combining+multiple interfaces (which they call "effects") via the type-level list which+parameterizes the [Eff] type.++```haskell+data Eff (es :: [Effect]) a++type Effect = (Type -> Type) -> Type -> Type+```++I have left this feature out because I do not currently have any pressing need+for it, I find it too difficult to use, and I am not convinced that it needs to+be built into this library. It is possible to express the combination of two+supply-chain interfaces as:++```haskell+data Either interface1 interface2 response =+    Left (interface1 response) | Right (interface2 response)+```++`Either` may be nested to produce interface combinations larger than two.+Although this approach is cumbersome, it does suggest that more clever+conveniences could be designed.++  [pipes]: https://hackage.haskell.org/package/pipes++  [Proxy]: https://github.com/Gabriella439/pipes/blob/e43acc24100dca20cdb901d91a7553143b2c1369/src/Pipes/Internal.hs#L72-L76++  [haxl]: https://hackage.haskell.org/package/haxl++  [Facebook example]: https://github.com/facebook/Haxl/blob/ef52a522fb851be8ed0a38bcd370d29310d5bba0/example/facebook/readme.md?plain=1#L35-L38++  [effectful]: https://hackage.haskell.org/package/effectful++  [dynamic State effect]: https://github.com/haskell-effectful/effectful/blob/b6cd978db35d66dbfa82ce74b0d011833411248a/effectful-core/src/Effectful/State/Dynamic.hs#L38-L42++  [transformers]: https://hackage.haskell.org/package/transformers++  [StateT]: https://hackage.haskell.org/package/transformers-0.6.0.4/docs/Control-Monad-Trans-State-Strict.html++  [functional dependencies]: https://downloads.haskell.org/~ghc/latest/docs/users_guide/exts/functional_dependencies.html++  [Eff]: https://github.com/haskell-effectful/effectful/blob/c385b16b2b756cf27f60116714dfbcc7dc1c272d/effectful-core/src/Effectful/Internal/Monad.hs#L104-L122
+ supply-chain-core.cabal view
@@ -0,0 +1,64 @@+cabal-version: 3.0++name: supply-chain-core+version: 0.0.0.0++category: Monads, Streaming+synopsis: Composable request-response pipelines++description:+    This package defines the @Job@ and @Vendor@ types that are the+    focus of the @supply-chain@ package. The core package is provided+    for the sake of exposing all of the internal detail. More likely+    you want to use @supply-chain@ instead, which aims to be+    friendlier and subject to fewer breaking releases.++author: Chris Martin+maintainer: Chris Martin, Julie Moronuki++homepage: https://github.com/typeclasses/supply-chain-core+bug-reports: https://github.com/typeclasses/supply-chain-core/issues++license: Apache-2.0+license-file: license.txt++extra-doc-files: readme.md changelog.md++common base+    default-language: GHC2021+    ghc-options: -Wall+    default-extensions:+        LambdaCase+        NoImplicitPrelude+        PatternSynonyms+        TypeFamilies+        ViewPatterns++    build-depends:+        base ^>= 4.16 || ^>= 4.17++library+    import: base+    hs-source-dirs: supply-chain-core+    exposed-modules:+        SupplyChain.Core.Connect+        SupplyChain.Core.Effect+        SupplyChain.Core.FreeMonad+        SupplyChain.Core.FreePointedFunctor+        SupplyChain.Core.Job+        SupplyChain.Core.JobAndVendor+        SupplyChain.Core.Referral+        SupplyChain.Core.Unit+        SupplyChain.Core.Vendor+        SupplyChain.Core.VendorAndReferral++test-suite test-supply-chain-core+    import: base+    type: exitcode-stdio-1.0+    hs-source-dirs: test-supply-chain-core+    main-is: Main.hs+    build-depends:+        supply-chain-core+      , tasty ^>= 1.3 || ^>= 1.4+      , tasty-hedgehog ^>= 1.3 || ^>= 1.4+      , tasty-hunit ^>= 0.10
+ supply-chain-core/SupplyChain/Core/Connect.hs view
@@ -0,0 +1,58 @@+-- | Description: functions to combine vendors and jobs++module SupplyChain.Core.Connect+  (+    {- * Vendor to job -} (>-), (>+),+    {- * Vendor to vendor -} (>->),+    {- * Referral -} joinReferral,+  )+  where++import Control.Monad ((>>=))+import Data.Functor ((<&>), fmap)++import SupplyChain.Core.Job (Job)+import SupplyChain.Core.Referral (Referral (Referral))+import SupplyChain.Core.Vendor (Vendor (Vendor, handle))++import qualified SupplyChain.Core.Job as Job+import qualified SupplyChain.Core.Referral as Referral+import qualified SupplyChain.Core.Vendor as Vendor++infixl 6 >-+infixl 6 >++infixl 7 >->++{-| Modify a job with a vendor that interprets its requests -}+(>-) :: Vendor up down action -- ^ Upstream+     -> Job down action product -- ^ Downstream+     -> Job up action product+up >- down = up >+ down <&> Referral.product++{-| Connect two vendors; the first interprets requests made by the second -}+(>->) :: Vendor up middle action -- ^ Upstream+      -> Vendor middle down action -- ^ Downstream+      -> Vendor up down action+up >-> down = Vendor { handle = \request ->+    up >+ (Vendor.handle down request) <&> joinReferral }++{-| Sort of resembles what a 'Control.Monad.join' implementation for 'Referral'+    might look like, modulo a subtle difference in the types -}+joinReferral :: Referral up middle action (Referral middle down action product)+    -> Referral up down action product+joinReferral (Referral (Referral product nextDown) nextUp) =+    Referral product (nextUp >-> nextDown)++{-| Connect a vendor to a job, producing a job which returns both the product+    and a new version of the vendor.++    Use this function instead of '(>-)' if you need to attach a succession+    of jobs to one stateful vendor. -}+(>+) :: Vendor up down action -- ^ Upstream+     -> Job down action product -- ^ Downstream+     -> Job up action (Referral up down action product)+up >+ job = case job of+    Job.Pure product -> Job.Pure (Referral product up)+    Job.Perform action extract -> Job.Perform action extract <&> (`Referral` up)+    Job.Request request extract -> Vendor.handle up request <&> fmap extract+    Job.Bind a b -> up >+ a >>= \(Referral x up') -> up' >+ b x
+ supply-chain-core/SupplyChain/Core/Effect.hs view
@@ -0,0 +1,42 @@+-- | Description: an /effect/ is either /request/ or /perform/++module SupplyChain.Core.Effect+  (+    {- * Type -} Effect (Request, Perform),+    {- * Running -} run, absurd,+    {- * Alteration -} alterRequest, alterPerform,+  )+  where++import Data.Functor.Const (Const)+import Data.Void (Void)++data Effect up action product =+    Request (up product) | Perform (action product)++run :: Effect (Const Void) action product -- ^ An effect that makes no requests+    -> action product+run = \case+    Perform x -> x+    Request x -> case x of {}++absurd ::+    Effect (Const Void) (Const Void) x -- ^ There are values of this type.+    -> product+absurd = \case+    Perform x -> case x of {}+    Request x -> case x of {}++alterRequest ::+    (up product -> Effect up' action product) -- ^ Modification to requests+    -> Effect up action product -> Effect up' action product+alterRequest f = \case+    Perform x -> Perform x+    Request x -> f x++alterPerform ::+    (action product -> Effect up action' product) -- ^ Modification to actions+    -> Effect up action product -> Effect up action' product+alterPerform f = \case+    Request x -> Request x+    Perform x -> f x
+ supply-chain-core/SupplyChain/Core/FreeMonad.hs view
@@ -0,0 +1,74 @@+-- | Description: makes a monad of any type constructor++module SupplyChain.Core.FreeMonad+  (+    {- * Type -} FreeMonad (Step, Bind, Pure, Map),+    {- * Running -} run, eval,+    {- * Alteration -} alter,+  )+  where++import Control.Applicative (Applicative (pure, (<*>)))+import Control.Monad (Monad ((>>=)))+import Data.Function ((&), ($), (.))+import Data.Functor (Functor, (<&>))+import SupplyChain.Core.FreePointedFunctor (FreePointedFunctor)++import qualified Control.Monad as Monad+import qualified SupplyChain.Core.FreePointedFunctor as FreePointedFunctor++data FreeMonad f a =+    Step (FreePointedFunctor f a)+  | forall x. Bind (FreeMonad f x) (x -> FreeMonad f a)++pattern Pure :: a -> FreeMonad f a+pattern Pure a = Step (FreePointedFunctor.Pure a)++pattern Map :: f x -> (x -> a) -> FreeMonad f a+pattern Map action extract = Step (FreePointedFunctor.Map action extract)++{-# complete Pure, Map, Bind #-}++deriving instance Functor (FreeMonad f)++instance Applicative (FreeMonad f) where pure = Pure; (<*>) = Monad.ap++instance Monad (FreeMonad f) where (>>=) = Bind++run :: Monad effect =>+    (forall x. f x -> effect x) -- ^ How to interpret @f@ actions+    -> FreeMonad f a -> effect a+run (runEffect :: forall x. f x -> effect x) = recur+  where+    runPF :: FreePointedFunctor f x -> effect x+    runPF = FreePointedFunctor.run runEffect++    recur :: FreeMonad f x -> effect x+    recur = \case+        Step a -> runPF a+        Bind (Step a) b -> runPF a >>= \x -> recur $ b x+        Bind (Bind a b) c -> recur a >>= \x -> recur $ Bind (b x) c++eval :: (forall x. f x -> x) -- ^ How to interpret @f@ actions+    -> FreeMonad f a+    -> a+eval (evalEffect :: forall x. f x -> x) = recur+  where+    evalPF :: FreePointedFunctor f x -> x+    evalPF = FreePointedFunctor.eval evalEffect++    recur :: FreeMonad f x -> x+    recur = \case+        Step a -> evalPF a+        Bind (Step a) b -> evalPF a & \x -> recur $ b x+        Bind (Bind a b) c -> recur a & \x -> recur $ Bind (b x) c++alter :: (forall x. f x -> FreeMonad f' x)+    -> FreeMonad f a -> FreeMonad f' a+alter (f :: forall x. f x -> FreeMonad f' x) = recur+  where+    recur :: FreeMonad f x -> FreeMonad f' x+    recur = \case+        Pure x -> Pure x+        Map action extract -> f action <&> extract+        Bind a b -> Bind (recur a) (recur . b)
+ supply-chain-core/SupplyChain/Core/FreePointedFunctor.hs view
@@ -0,0 +1,40 @@+-- | Description: makes a pointed functor of any type constructor++module SupplyChain.Core.FreePointedFunctor+  (+    {- * Type -} FreePointedFunctor (Pure, Map),+    {- * Running -} run, eval,+    {- * Alteration -} alter,+  )+  where++import Control.Applicative (pure)+import Control.Monad (Monad)+import Data.Function ((&))+import Data.Functor (Functor, (<&>))++data FreePointedFunctor f product =+    Pure product+  | forall x. Map (f x) (x -> product)++deriving instance Functor (FreePointedFunctor f)++run :: Monad effect =>+    (forall x. f x -> effect x) -- ^ How to interpret @f@ actions+    -> FreePointedFunctor f product -> effect product+run runEffect = \case+    Pure product -> pure product+    Map action extract -> runEffect action <&> extract++eval ::+    (forall x. f x -> x) -- ^ How to interpret @f@ actions+    -> FreePointedFunctor f product -> product+eval evalF = \case+    Pure product -> product+    Map action extract -> evalF action & extract++alter :: (forall x. f x -> FreePointedFunctor f' x)+    -> FreePointedFunctor f product -> FreePointedFunctor f' product+alter f = \case+    Pure product -> Pure product+    Map action extract -> f action <&> extract
+ supply-chain-core/SupplyChain/Core/Job.hs view
@@ -0,0 +1,73 @@+-- | Description: a /job/ makes requests, performs actions, and returns++module SupplyChain.Core.Job+  (+    {- * Type -} Job (FreeMonad, Pure, Effect, Request, Perform, Bind),+    {- * Constructing -} effect, perform, order,+    {- * Running -} run, eval,+    {- * Alteration -} alter,+  )+  where++import Control.Applicative (Applicative)+import Control.Monad (Monad)+import Data.Function ((.), id)+import Data.Functor (Functor)+import Data.Functor.Const (Const)+import Data.Void (Void)+import SupplyChain.Core.Effect (Effect)+import SupplyChain.Core.FreeMonad (FreeMonad)++import qualified SupplyChain.Core.Effect as Effect+import qualified SupplyChain.Core.FreeMonad as FreeMonad++{-| Monadic context that supports making requests, performing actions,+    and returning a single result -}+newtype Job up action product =+    FreeMonad { freeMonad :: FreeMonad (Effect up action) product }++pattern Pure :: product -> Job up action product+pattern Pure product = FreeMonad (FreeMonad.Pure product)++pattern Effect :: Effect up action x -> (x -> product) -> Job up action product+pattern Effect effect extract = FreeMonad (FreeMonad.Map effect extract)++pattern Request :: up x -> (x -> product) -> Job up action product+pattern Request request extract = Effect (Effect.Request request) extract++pattern Perform :: action x -> (x -> product) -> Job up action product+pattern Perform action extract = Effect (Effect.Perform action) extract++pattern Bind :: (Job up action x) -> (x -> Job up action a) -> Job up action a+pattern Bind a b <- FreeMonad (FreeMonad.Bind (FreeMonad -> a) ((FreeMonad .) -> b))+  where Bind a b = FreeMonad (FreeMonad.Bind (freeMonad a) (freeMonad . b))++{-# complete Pure, Effect, Bind #-}+{-# complete Pure, Request, Perform, Bind #-}++deriving instance Functor (Job up action)+deriving instance Applicative (Job up action)+deriving instance Monad (Job up action)++effect :: Effect up action product -> Job up action product+effect x = Effect x id++-- | Send a request via the job's upstream 'Interface'+order :: up product -> Job up action product+order x = Request x id++-- | Perform an action in a job's 'Action' context+perform :: action product -> Job up action product+perform x = Perform x id++-- | Run a job in its 'Action' context+run :: Monad action => Job (Const Void) action product -> action product+run = FreeMonad.run Effect.run . freeMonad++-- | Run a job that performs no actions+eval :: Job (Const Void) (Const Void) product -> product+eval = FreeMonad.eval Effect.absurd . freeMonad++alter :: (forall x. Effect up action x -> Job up' action' x)+    -> Job up action product -> Job up' action' product+alter f = FreeMonad . FreeMonad.alter (freeMonad . f) . freeMonad
+ supply-chain-core/SupplyChain/Core/JobAndVendor.hs view
@@ -0,0 +1,33 @@+-- | Description: /job/ + /vendor/++module SupplyChain.Core.JobAndVendor+  (+    {- * Types -} Job (..), Vendor (..),+    {- * Alteration -} alterJob, alterVendor,+    {- * Conversion -} loop, once,+  )+  where++import SupplyChain.Core.Effect (Effect)+import SupplyChain.Core.Job (Job)+import SupplyChain.Core.Referral (Referral (Referral))+import SupplyChain.Core.Unit (Unit (Unit))+import SupplyChain.Core.Vendor (Vendor (Vendor, handle))+import SupplyChain.Core.VendorAndReferral (alterVendor)++import qualified SupplyChain.Core.Job as Job+import qualified SupplyChain.Core.Referral as Referral++import Data.Functor++alterJob :: (forall x. Effect up action x -> Job up' action' x)+    -> Job up action product -> Job up' action' product+alterJob = Job.alter++loop :: Job up action product -> Vendor up (Unit product) action+loop j = go+  where+    go = Vendor{ handle = \Unit -> j <&> \product -> Referral product go }++once :: Vendor up (Unit product) action -> Job up action product+once v = handle v Unit <&> Referral.product
+ supply-chain-core/SupplyChain/Core/Referral.hs view
@@ -0,0 +1,18 @@+-- | Description: a /referral/ consists of a product and a new vendor++module SupplyChain.Core.Referral+  (+    {- * Type -} Referral (..),+    {- * Alteration -} alter,+  )+  where++import SupplyChain.Core.Effect (Effect)+import SupplyChain.Core.Job (Job)+import SupplyChain.Core.VendorAndReferral (Referral)++import qualified SupplyChain.Core.VendorAndReferral as VendorAndReferral++alter :: (forall x. Effect up action x -> Job up' action' x)+    -> Referral up down action product -> Referral up' down action' product+alter = VendorAndReferral.alterReferral
+ supply-chain-core/SupplyChain/Core/Unit.hs view
@@ -0,0 +1,12 @@+-- | Description: /unit/ is a simple interface with one request and a fixed+--                response type++module SupplyChain.Core.Unit+  (+    {- * Type -} Unit (Unit),+  )+  where++{-| @Unit a@ is a simple interface: It has a single request+    value (@Unit@), and a fixed response type (@a@). -}+data Unit a b = a ~ b => Unit
+ supply-chain-core/SupplyChain/Core/Vendor.hs view
@@ -0,0 +1,41 @@+-- | Description: a /vendor/ responds to requests, makes requests, and+--                performs actions++module SupplyChain.Core.Vendor+  (+    {- * Type -} Vendor (..),+    {- * Running -} run, eval,+    {- * Alteration -} alter,+  )+  where++import Control.Monad (Monad)+import Data.Functor.Const (Const)+import Data.Void (Void)+import SupplyChain.Core.Effect (Effect)+import SupplyChain.Core.Job (Job)+import SupplyChain.Core.VendorAndReferral (Vendor (..), Referral (..))++import qualified SupplyChain.Core.Job as Job+import qualified SupplyChain.Core.VendorAndReferral as VendorAndReferral++{-| An action in which a vendor handles a single request++    The action returns a 'Referral', which contains two things:++    - The response to the request+    - A new version of the vendor+-}+run :: Monad action => Vendor (Const Void) down action+    -> down product -- ^ Request+    -> action (Referral (Const Void) down action product)+run v r = Job.run (handle v r)++eval :: Vendor (Const Void) down (Const Void)+    -> down product  -- ^ Request+    -> Referral (Const Void) down (Const Void) product+eval v r = Job.eval (handle v r)++alter :: (forall x. Effect up action x -> Job up' action' x)+    -> Vendor up down action -> Vendor up' down action'+alter = VendorAndReferral.alterVendor
+ supply-chain-core/SupplyChain/Core/VendorAndReferral.hs view
@@ -0,0 +1,44 @@+-- | Description: /vendor/ + /referral/++module SupplyChain.Core.VendorAndReferral+  (+    {- * Types -} Vendor (..), Referral (..),+    {- * Alteration -} alterVendor, alterReferral,+  )+  where++import Data.Foldable (Foldable)+import Data.Function ((.))+import Data.Functor (Functor, fmap)+import Data.Traversable (Traversable)+import SupplyChain.Core.Effect (Effect)+import SupplyChain.Core.Job (Job)++import qualified SupplyChain.Core.Job as Job++-- | Makes requests, responds to requests, and performs actions+newtype Vendor up down action =+  Vendor+    { handle :: forall product.+        down product -> Job up action (Referral up down action product) }++-- | The conclusion of a vendor's handling of a client request+data Referral up down action product =+  Referral+    { product :: product -- ^ The requested product+    , next :: Vendor up down action+        -- ^ A new vendor to handle subsequent requests+    }++deriving instance Functor (Referral up down action)+deriving instance Foldable (Referral up down action)+deriving instance Traversable (Referral up down action)++alterVendor :: (forall x. Effect up action x -> Job up' action' x)+    -> Vendor up down action -> Vendor up' down action'+alterVendor f v =+    Vendor{ handle = fmap (alterReferral f) . Job.alter f . handle v }++alterReferral :: (forall x. Effect up action x -> Job up' action' x)+    -> Referral up down action product -> Referral up' down action' product+alterReferral f s = s{ next = alterVendor f (next s) }
+ test-supply-chain-core/Main.hs view
@@ -0,0 +1,73 @@+module Main (main) where++import Control.Applicative (pure, (<*>))+import Data.Function (($))+import Data.Functor ((<&>), (<$>))+import Data.Functor.Identity (Identity (Identity))+import Data.Maybe (Maybe (..))+import Data.Semigroup ((<>))+import Prelude (Int, succ)+import SupplyChain.Core.Connect ((>-))+import SupplyChain.Core.Job (order, perform)+import SupplyChain.Core.Referral (Referral (Referral))+import SupplyChain.Core.Vendor (Vendor (Vendor, handle))+import System.IO (IO)+import Test.Tasty (defaultMain, testGroup, TestTree)+import Test.Tasty.HUnit ((@?=), testCase)++import qualified Data.List as List+import qualified SupplyChain.Core.Job as Job++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Core"+    [ testGroup "pure _"+        [ testCase "run Identity" $ Job.run (pure 'a') @?= Identity 'a'+        , testCase "run Maybe" $ Job.run (pure 'a') @?= Just 'a'+        , testCase "eval" $ Job.eval (pure 'a') @?= 'a'+        ]+    , testGroup "pure _ <&> _"+        [ testCase "run Identity" $ Job.run (pure 'a' <&> succ) @?= Identity 'b'+        , testCase "run Maybe" $ Job.run (pure 'a' <&> succ) @?= Just 'b'+        , testCase "eval" $ Job.eval (pure 'a' <&> succ) @?= 'b'+        ]+    , testGroup "perform"+        [ testCase "Single" $ Job.run (perform ['a', 'b']) @?= ['a', 'b']+        , testCase "Functor" $ Job.run (perform ['a', 'b'] <&> succ) @?= ['b', 'c']+        , testCase "Applicative composition" $+            Job.run ((<>) <$> perform ["a", "b"] <*> perform ["c", "d"])+            @?= ["ac", "ad", "bc", "bd"]+        , let+            j = do+              a <- perform [1 :: Int, 3]+              b <- perform ['a', 'b', 'c']+              perform (List.replicate a b)+          in+            testCase "Monadic composition" $ Job.run j @?= "abcaaabbbccc"+        ]+    , testGroup "order" $+        let+          -- Converts dynamic effects to static effects+          f = (go >-)+            where+              go = Vendor { handle = \x -> perform x <&> (`Referral` go) }+        in+        [ testCase "Single" $ Job.run (f $ order ['a', 'b']) @?= ['a', 'b']+        , testCase "Functor" $ Job.run (f $ order ['a', 'b'] <&> succ) @?= ['b', 'c']+        , testCase "Applicative composition" $+            let+              j = f $ (<>) <$> order ["a", "b"] <*> order ["c", "d"]+            in+              Job.run j @?= ["ac", "ad", "bc", "bd"]+        , testCase "Monadic composition" $+            let+              j = do+                a <- order [1 :: Int, 3]+                b <- order ['a', 'b', 'c']+                order (List.replicate a b)+            in+              Job.run (f j) @?= "abcaaabbbccc"+        ]+    ]