selective-0.7/examples/0000755000000000000000000000000014374406574013365 5ustar0000000000000000selective-0.7/examples/Teletype/0000755000000000000000000000000014374406574015160 5ustar0000000000000000selective-0.7/src/0000755000000000000000000000000014374406574012336 5ustar0000000000000000selective-0.7/src/Control/0000755000000000000000000000000014374406574013756 5ustar0000000000000000selective-0.7/src/Control/Selective/0000755000000000000000000000000014374406574015701 5ustar0000000000000000selective-0.7/src/Control/Selective/Rigid/0000755000000000000000000000000014374406574016737 5ustar0000000000000000selective-0.7/src/Control/Selective/Trans/0000755000000000000000000000000014376571333016766 5ustar0000000000000000selective-0.7/test/0000755000000000000000000000000014374406574012526 5ustar0000000000000000selective-0.7/src/Control/Selective.hs0000644000000000000000000005352014374406574016242 0ustar0000000000000000{-# LANGUAGE CPP, LambdaCase, TupleSections, DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DerivingVia #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Selective -- Copyright : (c) Andrey Mokhov 2018-2023 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- -- This is a library for /selective applicative functors/, or just -- /selective functors/ for short, an abstraction between applicative functors -- and monads, introduced in this paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf. -- ----------------------------------------------------------------------------- module Control.Selective ( -- * Type class Selective (..), (<*?), branch, selectA, selectT, apS, selectM, -- * Conditional combinators ifS, whenS, fromMaybeS, orElse, andAlso, untilRight, whileS, (<||>), (<&&>), foldS, anyS, allS, bindS, Cases, casesEnum, cases, matchS, matchM, -- * Selective functors SelectA (..), SelectM (..), Over (..), Under (..), Validation (..), -- * Miscellaneous swapEither, ComposeEither (..), ComposeTraversable (..) ) where import Control.Applicative import Control.Applicative.Lift import Control.Arrow import Control.Monad.ST import Control.Monad.Trans.Cont import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Control.Monad.Trans.RWS import Control.Monad.Trans.State import Control.Monad.Trans.Writer import Data.Bool import Data.Function import Data.Functor.Compose import Data.Functor.Identity import Data.Functor.Product import Data.List.NonEmpty import Data.Proxy import Data.Semigroup (Semigroup (..)) import GHC.Conc (STM) import qualified Control.Monad.Trans.RWS.Strict as S import qualified Control.Monad.Trans.State.Strict as S import qualified Control.Monad.Trans.Writer.Strict as S -- | Selective applicative functors. You can think of 'select' as a selective -- function application: when given a value of type 'Left' @a@, you __must apply__ -- the given function, but when given a 'Right' @b@, you __may skip__ the -- function and associated effects, and simply return the @b@. -- -- Note that it is not a requirement for selective functors to skip unnecessary -- effects. It may be counterintuitive, but this makes them more useful. Why? -- Typically, when executing a selective computation, you would want to skip the -- effects (saving work); but on the other hand, if your goal is to statically -- analyse a given selective computation and extract the set of all possible -- effects (without actually executing them), then you do not want to skip any -- effects, because that defeats the purpose of static analysis. -- -- The type signature of 'select' is reminiscent of both '<*>' and '>>=', and -- indeed a selective functor is in some sense a composition of an applicative -- functor and the 'Either' monad. -- -- Laws: -- -- * Identity: -- -- @ -- x \<*? pure id = either id id \<$\> x -- @ -- -- * Distributivity; note that @y@ and @z@ have the same type @f (a -> b)@: -- -- @ -- pure x \<*? (y *\> z) = (pure x \<*? y) *\> (pure x \<*? z) -- @ -- -- * Associativity: -- -- @ -- x \<*? (y \<*? z) = (f \<$\> x) \<*? (g \<$\> y) \<*? (h \<$\> z) -- where -- f x = Right \<$\> x -- g y = \a -\> bimap (,a) ($a) y -- h z = uncurry z -- @ -- -- * Monadic 'select' (for selective functors that are also monads): -- -- @ -- select = selectM -- @ -- -- There are also a few useful theorems: -- -- * Apply a pure function to the result: -- -- @ -- f \<$\> select x y = select (fmap f \<$\> x) (fmap f \<$\> y) -- @ -- -- * Apply a pure function to the @Left@ case of the first argument: -- -- @ -- select (first f \<$\> x) y = select x ((. f) \<$\> y) -- @ -- -- * Apply a pure function to the second argument: -- -- @ -- select x (f \<$\> y) = select (first (flip f) \<$\> x) ((&) \<$\> y) -- @ -- -- * Generalised identity: -- -- @ -- x \<*? pure y = either y id \<$\> x -- @ -- -- * A selective functor is /rigid/ if it satisfies '<*>' @=@ 'apS'. The -- following /interchange/ law holds for rigid selective functors: -- -- @ -- x *\> (y \<*? z) = (x *\> y) \<*? z -- @ -- -- If f is also a 'Monad', we require that 'select' = 'selectM', from which one -- can prove '<*>' @=@ 'apS'. class Applicative f => Selective f where select :: f (Either a b) -> f (a -> b) -> f b {- Why do we have skew associativity, where we can reassociate effects to the left but not to the right? The following two tables, which list all possible combinations of effect execution and skipping, might give you some intuition on why this happens. --------------- (x <*? y) <*? z --------------- 1 0 0 1 1 0 1 0 1 1 1 1 --------------- x <*? (y <*? z) --------------- 1 0 0 1 1 0 1 1 1 A key observation is that when effects are associated to the right, we can't skip the effect y and execute the effect z: combination 101 is impossible. -} -- | An operator alias for 'select', which is sometimes convenient. It tries to -- follow the notational convention for 'Applicative' operators. The angle -- bracket pointing to the left means we always use the corresponding value. -- The value on the right, however, may be skipped, hence the question mark. (<*?) :: Selective f => f (Either a b) -> f (a -> b) -> f b (<*?) = select infixl 4 <*? -- | The 'branch' function is a natural generalisation of 'select': instead of -- skipping an unnecessary effect, it chooses which of the two given effectful -- functions to apply to a given argument; the other effect is unnecessary. It -- is possible to implement 'branch' in terms of 'select', which is a good -- puzzle (give it a try!). -- -- We can also implement 'select' via 'branch': -- -- @ -- selectB :: Selective f => f (Either a b) -> f (a -> b) -> f b -- selectB x y = branch x y (pure id) -- @ -- branch :: Selective f => f (Either a b) -> f (a -> c) -> f (b -> c) -> f c branch x l r = fmap (fmap Left) x <*? fmap (fmap Right) l <*? r -- | We can write a function with the type signature of 'select' using the -- 'Applicative' type class, but it will always execute the effects associated -- with the second argument, hence being potentially less efficient. selectA :: Applicative f => f (Either a b) -> f (a -> b) -> f b selectA x y = (\e f -> either f id e) <$> x <*> y -- | For traversable functors, we can implement 'select' in another interesting -- way: the effects associated with the second argument can be skipped as long -- as the first argument contains only 'Right' values. selectT :: Traversable f => f (Either a b) -> f (a -> b) -> f b selectT x y = case sequenceA x of Left a -> ($a) <$> y Right fb -> fb {-| Recover the application operator '<*>' from 'select'. /Rigid/ selective functors satisfy the law '<*>' @=@ 'apS' and furthermore, the resulting applicative functor satisfies all laws of 'Applicative': * Identity: > pure id <*> v = v * Homomorphism: > pure f <*> pure x = pure (f x) * Interchange: > u <*> pure y = pure ($y) <*> u * Composition: > (.) <$> u <*> v <*> w = u <*> (v <*> w) -} apS :: Selective f => f (a -> b) -> f a -> f b apS f x = select (Left <$> f) ((&) <$> x) -- | One can easily implement a monadic 'selectM' that satisfies the laws, -- hence any 'Monad' is 'Selective'. selectM :: Monad f => f (Either a b) -> f (a -> b) -> f b selectM x y = x >>= \case Left a -> ($a) <$> y -- execute y Right b -> pure b -- skip y -- Many useful 'Monad' combinators can be implemented with 'Selective' -- | Branch on a Boolean value, skipping unnecessary effects. ifS :: Selective f => f Bool -> f a -> f a -> f a ifS x t e = branch (bool (Right ()) (Left ()) <$> x) (const <$> t) (const <$> e) -- Implementation used in the paper: -- ifS x t e = branch selector (fmap const t) (fmap const e) -- where -- selector = bool (Right ()) (Left ()) <$> x -- NB: convert True to Left () -- | Eliminate a specified value @a@ from @f (Either a b)@ by replacing it -- with a given @f b@. eliminate :: (Eq a, Selective f) => a -> f b -> f (Either a b) -> f (Either a b) eliminate x fb fa = select (match x <$> fa) (const . Right <$> fb) where match _ (Right y) = Right (Right y) match x (Left y) = if x == y then Left () else Right (Left y) -- | A list of values, equipped with a fast membership test. data Cases a = Cases [a] (a -> Bool) -- | The list of all possible values of an enumerable data type. casesEnum :: (Bounded a, Enum a) => Cases a casesEnum = Cases [minBound..maxBound] (const True) -- | Embed a list of values into 'Cases' using the trivial but slow membership -- test based on 'elem'. cases :: Eq a => [a] -> Cases a cases as = Cases as (`elem` as) -- | Eliminate all specified values @a@ from @f (Either a b)@ by replacing each -- of them with a given @f a@. matchS :: (Eq a, Selective f) => Cases a -> f a -> (a -> f b) -> f (Either a b) matchS (Cases cs _) x f = foldr (\c -> eliminate c (f c)) (Left <$> x) cs -- | Eliminate all specified values @a@ from @f (Either a b)@ by replacing each -- of them with a given @f a@. matchM :: Monad m => Cases a -> m a -> (a -> m b) -> m (Either a b) matchM (Cases _ p) mx f = do x <- mx if p x then Right <$> f x else pure (Left x) -- TODO: Add a type-safe version based on @KnownNat@. -- | A restricted version of monadic bind. Fails with an error if the 'Bounded' -- and 'Enum' instances for @a@ do not cover all values of @a@. bindS :: (Bounded a, Enum a, Eq a, Selective f) => f a -> (a -> f b) -> f b bindS x f = fromRight <$> matchS casesEnum x f where fromRight (Right b) = b fromRight _ = error "Selective.bindS: incorrect Bounded and/or Enum instance" -- | Conditionally perform an effect. whenS :: Selective f => f Bool -> f () -> f () whenS x y = select (bool (Right ()) (Left ()) <$> x) (const <$> y) -- Implementation used in the paper: -- whenS x y = selector <*? effect -- where -- selector = bool (Right ()) (Left ()) <$> x -- NB: maps True to Left () -- effect = const <$> y -- | A lifted version of 'Data.Maybe.fromMaybe'. fromMaybeS :: Selective f => f a -> f (Maybe a) -> f a fromMaybeS x mx = select (maybe (Left ()) Right <$> mx) (const <$> x) -- | Return the first @Right@ value. If both are @Left@'s, accumulate errors. orElse :: (Selective f, Semigroup e) => f (Either e a) -> f (Either e a) -> f (Either e a) orElse x y = select (prepare <$> x) (combine <$> y) where prepare :: Either e a -> Either e (Either e a) prepare = fmap Right combine :: Semigroup e => Either e a -> e -> Either e a combine (Left ey) ex = Left (ex <> ey) combine (Right a) _ = Right a -- | Accumulate the @Right@ values, or return the first @Left@. andAlso :: (Selective f, Semigroup a) => f (Either e a) -> f (Either e a) -> f (Either e a) andAlso x y = swapEither <$> orElse (swapEither <$> x) (swapEither <$> y) -- | Swap @Left@ and @Right@. swapEither :: Either a b -> Either b a swapEither = either Right Left -- | Keep checking an effectful condition while it holds. whileS :: Selective f => f Bool -> f () whileS act = whenS act (whileS act) -- | Keep running an effectful computation until it returns a @Right@ value, -- collecting the @Left@'s using a supplied @Monoid@ instance. untilRight :: (Monoid a, Selective f) => f (Either a b) -> f (a, b) untilRight x = select y h where -- y :: f (Either a (a, b)) y = fmap (mempty,) <$> x -- h :: f (a -> (a, b)) h = (\(as, b) a -> (mappend a as, b)) <$> untilRight x -- | A lifted version of lazy Boolean OR. (<||>) :: Selective f => f Bool -> f Bool -> f Bool a <||> b = ifS a (pure True) b -- | A lifted version of lazy Boolean AND. (<&&>) :: Selective f => f Bool -> f Bool -> f Bool a <&&> b = ifS a b (pure False) -- | A lifted version of 'any'. Retains the short-circuiting behaviour. anyS :: Selective f => (a -> f Bool) -> [a] -> f Bool anyS p = foldr ((<||>) . p) (pure False) -- | A lifted version of 'all'. Retains the short-circuiting behaviour. allS :: Selective f => (a -> f Bool) -> [a] -> f Bool allS p = foldr ((<&&>) . p) (pure True) -- | Generalised folding with the short-circuiting behaviour. foldS :: (Selective f, Foldable t, Monoid a) => t (f (Either e a)) -> f (Either e a) foldS = foldr andAlso (pure (Right mempty)) -- Instances -- | Any applicative functor can be given a 'Selective' instance by defining -- 'select' @=@ 'selectA'. This data type captures this pattern, so you can use -- it in combination with the @DerivingVia@ extension as follows: -- -- @ -- newtype Over m a = Over m -- deriving (Functor, Applicative, Selective) via SelectA (Const m) -- @ -- newtype SelectA f a = SelectA { getSelectA :: f a } deriving (Functor, Applicative) instance Applicative f => Selective (SelectA f) where select = selectA -- Note: Validation e a ~ Lift (Under e) a instance Selective f => Selective (Lift f) where select (Pure (Right x)) _ = Pure x -- Lazy in the second argument select x (Pure y) = either y id <$> x select (Pure (Left x)) (Other y) = Other $ ($x) <$> y select (Other x ) (Other y) = Other $ x <*? y -- | Any monad can be given a 'Selective' instance by defining -- 'select' @=@ 'selectM'. This data type captures this pattern, so you can use -- it in combination with the @DerivingVia@ extension as follows: -- -- @ -- newtype V1 a = V1 a -- deriving (Functor, Applicative, Selective, Monad) via SelectM Identity -- @ -- newtype SelectM f a = SelectM { getSelectM :: f a } deriving (Functor, Applicative, Monad) instance Monad f => Selective (SelectM f) where select = selectM -- | Static analysis of selective functors with over-approximation. newtype Over m a = Over { getOver :: m } deriving (Eq, Functor, Ord, Show) deriving Applicative via (Const m) -- select = selectA instance Monoid m => Selective (Over m) where select (Over x) (Over y) = Over (mappend x y) -- | Static analysis of selective functors with under-approximation. newtype Under m a = Under { getUnder :: m } deriving (Eq, Functor, Ord, Show, Foldable, Traversable) deriving Applicative via (Const m) -- select = selectT instance Monoid m => Selective (Under m) where select (Under m) _ = Under m -- The 'Selective' 'ZipList' instance corresponds to the SIMT execution model. -- Quoting https://en.wikipedia.org/wiki/Single_instruction,_multiple_threads: -- -- "...to handle an IF-ELSE block where various threads of a processor execute -- different paths, all threads must actually process both paths (as all threads -- of a processor always execute in lock-step), but masking is used to disable -- and enable the various threads as appropriate..." instance Selective ZipList where select = selectA -- | Selective instance for the standard applicative functor Validation. This is -- a good example of a non-trivial selective functor which is not a monad. data Validation e a = Failure e | Success a deriving (Eq, Functor, Ord, Show) instance Semigroup e => Applicative (Validation e) where pure = Success Failure e1 <*> Failure e2 = Failure (e1 <> e2) Failure e1 <*> Success _ = Failure e1 Success _ <*> Failure e2 = Failure e2 Success f <*> Success a = Success (f a) instance Semigroup e => Selective (Validation e) where select (Success (Left a)) f = ($a) <$> f select (Success (Right b)) _ = Success b select (Failure e ) _ = Failure e instance (Selective f, Selective g) => Selective (Product f g) where select (Pair fx gx) (Pair fy gy) = Pair (select fx fy) (select gx gy) instance Selective f => Selective (IdentityT f) where select (IdentityT x) (IdentityT y) = IdentityT (select x y) instance Selective f => Selective (ReaderT env f) where select (ReaderT x) (ReaderT y) = ReaderT $ \env -> select (x env) (y env) distributeEither :: (Either a b, w) -> Either (a, w) (b, w) distributeEither (Left a, w) = Left (a, w) distributeEither (Right b, w) = Right (b, w) distributeFunction :: Monoid w => (a -> b, w) -> (a, w) -> (b, w) distributeFunction (f, wf) (x, wx) = (f x, mappend wx wf) instance (Monoid w, Selective f) => Selective (WriterT w f) where select (WriterT x) (WriterT f) = WriterT $ select (distributeEither <$> x) (distributeFunction <$> f) instance (Monoid w, Selective f) => Selective (S.WriterT w f) where select (S.WriterT x) (S.WriterT f) = S.WriterT $ select (distributeEither <$> x) (distributeFunction <$> f) -- TODO: Is this a useful instance? Note that composition of 'Alternative' -- requires @f@ to be 'Alternative', and @g@ to be 'Applicative', which is -- opposite to what we have here: -- -- instance (Alternative f, Applicative g) => Alternative (Compose f g) ... -- instance (Applicative f, Selective g) => Selective (Compose f g) where select (Compose x) (Compose y) = Compose (select <$> x <*> y) {- Here is why composing selective functors is tricky. Consider @Compose Maybe IO@. The only sensible implementation is: > select :: Maybe (IO (Either a b)) -> Maybe (IO (a -> b)) -> Maybe (IO b) > select Nothing _ = Nothing > select (Just x) (Just y) = Just (select x y) > select (Just x) Nothing = Nothing -- Can't use Just: we don't have @a -> b@! In other words, we have to be 'Applicative' on the outside functor 'Maybe', because there is no way to peek inside 'IO', which forces us to statically choose between 'Just', which doesn't work since we have no function @a -> b@, and 'Nothing' which corresponds to the behaviour of 'selectA'. -} -- Monad instances -- As a quick experiment, try: ifS (pure True) (print 1) (print 2) instance Selective IO where select = selectM -- And... we need to write a lot more instances instance Selective [] where select = selectM instance Monoid a => Selective ((,) a) where select = selectM instance Selective ((->) a) where select = selectM instance Selective (Either e) where select = selectM instance Selective Identity where select = selectM instance Selective Maybe where select = selectM instance Selective NonEmpty where select = selectM instance Selective Proxy where select = selectM instance Selective (ST s) where select = selectM instance Selective STM where select = selectM instance Selective (ContT r m) where select = selectM instance Monad m => Selective (MaybeT m) where select = selectM instance (Monoid w, Monad m) => Selective (RWST r w s m) where select = selectM instance (Monoid w, Monad m) => Selective (S.RWST r w s m) where select = selectM instance Monad m => Selective (StateT s m) where select = selectM instance Monad m => Selective (S.StateT s m) where select = selectM ------------------------------------ Arrows ------------------------------------ -- See the following standard definitions in "Control.Arrow". -- newtype ArrowMonad a o = ArrowMonad (a () o) -- instance Arrow a => Functor (ArrowMonad a) -- instance Arrow a => Applicative (ArrowMonad a) instance ArrowChoice a => Selective (ArrowMonad a) where select (ArrowMonad x) y = ArrowMonad $ x >>> (toArrow y ||| returnA) toArrow :: Arrow a => ArrowMonad a (i -> o) -> a i o toArrow (ArrowMonad f) = arr ((),) >>> first f >>> arr (uncurry ($)) ------------------------------ ComposeTraversable ------------------------------ -- | Composition of a selective functor @f@ and an applicative traversable -- functor @g@. newtype ComposeTraversable f g a = ComposeTraversable (f (g a)) deriving (Functor, Applicative) via Compose f g instance (Selective f, Applicative g, Traversable g) => Selective (ComposeTraversable f g) where select (ComposeTraversable x) (ComposeTraversable f) = ComposeTraversable $ select (prepare <$> x) (combine <$> f) where prepare :: Traversable g => g (Either a b) -> Either a (g b) prepare = sequenceA combine :: Traversable g => g (a -> b) -> a -> g b combine = sequenceA --------------------------------- ComposeEither -------------------------------- -- | Composition of a selective functor @f@ with the 'Either' monad. newtype ComposeEither f e a = ComposeEither (f (Either e a)) deriving Functor via Compose f (Either e) deriving Selective via ComposeTraversable f (Either e) instance Selective f => Applicative (ComposeEither f e) where pure = ComposeEither . pure . Right ComposeEither f <*> ComposeEither a = ComposeEither $ select (prepare <$> f) (combine <$> a) where prepare :: Either e (a -> b) -> Either (a -> b) (Either e b) prepare = either (Right . Left) Left combine :: Either e a -> (a -> b) -> Either e b combine = flip fmap ---------------------------------- Alternative --------------------------------- instance (Selective f, Monoid e) => Alternative (ComposeEither f e) where empty = ComposeEither (pure $ Left mempty) ComposeEither x <|> ComposeEither y = ComposeEither (x `orElse` y) {- One could also try implementing 'select' via 'Alternative' as follows: selectAlt :: Alternative f => f (Either a b) -> f (a -> b) -> f b selectAlt x y = failIfLeft x <|> selectA x y where failIfLeft :: Alternative f => f (Either a b) -> f b failIfLeft = undefined This has two issues: 1) A generic 'failIfLeft' if not possible, although many actual instances should be able to implement it. 2) More importantly, this requires duplication of work: if we failed because we happened to parse a 'Left' value in the first parser, then we need to rerun it, obtain a 'Left' once again, and then execute the second parser. Again, a specific instance may be able to cache the result and reuse it without duplicating any work, but this does not seem to be possible to achieve generically for any Alternative. -} selective-0.7/src/Control/Selective/Free.hs0000644000000000000000000000536614374406574017130 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Selective.Free -- Copyright : (c) Andrey Mokhov 2018-2023 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- -- This is a library for /selective applicative functors/, or just -- /selective functors/ for short, an abstraction between applicative functors -- and monads, introduced in this paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf. -- -- This module defines /free selective functors/ using the ideas from the -- Sjoerd Visscher's package 'free-functors': -- https://hackage.haskell.org/package/free-functors-1.0.1/docs/Data-Functor-HFree.html. -- ----------------------------------------------------------------------------- module Control.Selective.Free ( -- * Free selective functors Select (..), liftSelect, -- * Static analysis getPure, getEffects, getNecessaryEffects, runSelect, foldSelect ) where import Control.Selective import Data.Functor -- | Free selective functors. newtype Select f a = Select (forall g. Selective g => (forall x. f x -> g x) -> g a) -- Ignoring the hint, since GHC can't type check the suggested code. {-# ANN module "HLint: ignore Use fmap" #-} instance Functor (Select f) where fmap f (Select x) = Select $ \k -> f <$> x k instance Applicative (Select f) where pure a = Select $ \_ -> pure a Select x <*> Select y = Select $ \k -> x k <*> y k instance Selective (Select f) where select (Select x) (Select y) = Select $ \k -> x k <*? y k -- | Lift a functor into a free selective computation. liftSelect :: f a -> Select f a liftSelect x = Select (\f -> f x) -- | Given a natural transformation from @f@ to @g@, this gives a canonical -- natural transformation from @Select f@ to @g@. Note that here we rely on the -- fact that @g@ is a lawful selective functor. runSelect :: Selective g => (forall x. f x -> g x) -> Select f a -> g a runSelect k (Select x) = x k -- | Concatenate all effects of a free selective computation. foldSelect :: Monoid m => (forall x. f x -> m) -> Select f a -> m foldSelect f = getOver . runSelect (Over . f) -- | Extract the resulting value if there are no necessary effects. getPure :: Select f a -> Maybe a getPure = runSelect (const Nothing) -- | Collect /all possible effects/ in the order they appear in a free selective -- computation. getEffects :: Functor f => Select f a -> [f ()] getEffects = foldSelect (pure . void) -- | Extract /all necessary effects/ in the order they appear in a free -- selective computation. getNecessaryEffects :: Functor f => Select f a -> [f ()] getNecessaryEffects = getUnder . runSelect (Under . pure . void) selective-0.7/src/Control/Selective/Multi.hs0000644000000000000000000002465314374406574017341 0ustar0000000000000000{-# LANGUAGE DeriveFunctor, GADTs, RankNTypes, TupleSections, TypeOperators #-} {-# LANGUAGE ScopedTypeVariables, LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Selective.Multi -- Copyright : (c) Andrey Mokhov 2018-2023 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- -- This is a library for /selective applicative functors/, or just -- /selective functors/ for short, an abstraction between applicative functors -- and monads, introduced in this paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf. -- -- This module defines /multi-way selective functors/, which are more efficient -- when selecting from a large number of options. They also fully subsume the -- 'Applicative' type class because they allow to express the notion of -- independet effects. -- -- This definition is inspired by the following construction by Daniel Peebles, -- with the main difference being the added @Enumerable@ constraint: -- https://gist.github.com/copumpkin/d5bdbc7afda54ff04049b6bdbcffb67e -- ----------------------------------------------------------------------------- module Control.Selective.Multi ( -- * Generalised sum types Sigma (..), inject, Zero, One (..), Two (..), Many (..), many, matchPure, eitherToSigma, sigmaToEither, -- * Selective functors Some (..), Enumerable (..), Selective (..), Over (..), Under (..), select, branch, apS, bindS, -- * Applicative functors ApplicativeS (..), ap, matchA, -- * Monads MonadS (..), bind, matchM, -- * Generalised products and various combinators type (~>), Pi, project, identity, compose, apply, toSigma, fromSigma, toPi, fromPi, pairToPi, piToPair, Case (..), matchCases, ) where import Control.Applicative ((<**>)) import Data.Functor.Identity ------------------------ Meet two friends: Sigma and Pi ------------------------ -- | A generalised sum type where @t@ stands for the type of constructor "tags". -- Each tag has a type parameter @x@ which determines the type of the payload. -- A 'Sigma' @t@ value therefore contains a payload whose type is not visible -- externally but is revealed when pattern-matching on the tag. -- -- See 'Two', 'eitherToSigma' and 'sigmaToEither' for an example. data Sigma t where Sigma :: t x -> x -> Sigma t -- | An injection into a generalised sum. An alias for 'Sigma'. inject :: t x -> x -> Sigma t inject = Sigma -- | A data type defining no tags. Similar to 'Data.Void.Void' but parameterised. data Zero a where -- | A data type with a single tag. This data type is commonly known as @Refl@, -- see "Data.Type.Equality". data One a b where One :: One a a -- | A data type with two tags 'A' and 'B' that allows us to encode the good old -- 'Either' as 'Sigma' 'Two', where the tags 'A' and 'B' correspond to 'Left' -- and 'Right', respectively. See 'eitherToSigma' and 'sigmaToEither' that -- witness the isomorphism between 'Either' @a b@ and 'Sigma' @(@'Two'@ a b)@. data Two a b c where A :: Two a b a B :: Two a b b -- | Encode 'Either' into a generalised sum type. eitherToSigma :: Either a b -> Sigma (Two a b) eitherToSigma = \case Left a -> inject A a Right b -> inject B b -- | Decode 'Either' from a generalised sum type. sigmaToEither :: Sigma (Two a b) -> Either a b sigmaToEither = \case Sigma A a -> Left a Sigma B b -> Right b -- | A potentially uncountable collection of tags for the same unit @()@ payload. data Many a b where Many :: a -> Many a () many :: a -> Sigma (Many a) many a = Sigma (Many a) () -- | Generalised pattern matching on a Sigma type using a Pi type to describe -- how to handle each case. -- -- This is a specialisation of 'matchCases' for @f = Identity@. We could also -- have also given it the following type: -- -- @ -- matchPure :: Sigma t -> (t ~> Case Identity a) -> a -- @ -- -- We chose to simplify it by inlining '~>', 'Case' and 'Identity'. matchPure :: Sigma t -> (forall x. t x -> x -> a) -> a matchPure (Sigma t x) pi = pi t x ------------------------- Mutli-way selective functors ------------------------- -- | Hide the type of the payload a tag. -- -- There is a whole library dedicated to this nice little GADT: -- http://hackage.haskell.org/package/some. data Some t where Some :: t a -> Some t -- | A class of tags that can be enumerated. -- -- A valid instance must list every tag in the resulting list exactly once. class Enumerable t where enumerate :: [Some t] instance Enumerable Zero where enumerate = [] instance Enumerable (One a) where enumerate = [Some One] instance Enumerable (Two a b) where enumerate = [Some A, Some B] instance Enum a => Enumerable (Many a) where enumerate = [ Some (Many x) | x <- enumFrom (toEnum 0) ] -- | Multi-way selective functors. Given a computation that produces a value of -- a sum type, we can 'match' it to the corresponding computation in a given -- product type. -- -- For greater similarity with 'matchCases', we could have given the following -- type to 'match': -- -- @ -- match :: f (Sigma t) -> (t ~> Case f a) -> f a -- @ -- -- We chose to simplify it by inlining '~>' and 'Case'. class Applicative f => Selective f where match :: Enumerable t => f (Sigma t) -> (forall x. t x -> f (x -> a)) -> f a -- | The basic "if-then" selection primitive from "Control.Selective". select :: Selective f => f (Either a b) -> f (a -> b) -> f b select x f = match (eitherToSigma <$> x) $ \case A -> f B -> pure id -- | Choose a matching effect with 'Either'. branch :: Selective f => f (Either a b) -> f (a -> c) -> f (b -> c) -> f c branch x f g = match (eitherToSigma <$> x) $ \case A -> f B -> g -- | Recover the application operator '<*>' from 'match'. apS :: Selective f => f a -> f (a -> b) -> f b apS x f = match (inject One <$> x) (\One -> f) -- | A restricted version of monadic bind. bindS :: (Enum a, Selective f) => f a -> (a -> f b) -> f b bindS x f = match (many <$> x) (\(Many x) -> const <$> f x) -- | Static analysis of selective functors with over-approximation. newtype Over m a = Over { getOver :: m } deriving (Eq, Functor, Ord, Show) instance Monoid m => Applicative (Over m) where pure _ = Over mempty Over x <*> Over y = Over (mappend x y) instance Monoid m => Selective (Over m) where match (Over m) pi = Over (mconcat (m : ms)) where ms = [ getOver (pi t) | Some t <- enumerate ] -- | Static analysis of selective functors with under-approximation. newtype Under m a = Under { getUnder :: m } deriving (Eq, Functor, Ord, Show) instance Monoid m => Applicative (Under m) where pure _ = Under mempty Under x <*> Under y = Under (mappend x y) instance Monoid m => Selective (Under m) where match (Under m) _ = Under m -- | An alternative definition of applicative functors, as witnessed by 'ap' and -- 'matchOne'. This class is almost like 'Selective' but has a strict constraint -- on @t@. class Functor f => ApplicativeS f where pureA :: a -> f a matchOne :: t ~ One x => f (Sigma t) -> (forall x. t x -> f (x -> a)) -> f a -- | Recover the application operator '<*>' from 'matchOne'. ap :: ApplicativeS f => f a -> f (a -> b) -> f b ap x f = matchOne (Sigma One <$> x) (\One -> f) -- | Every 'Applicative' is also an 'ApplicativeS'. matchA :: (Applicative f, t ~ One x) => f (Sigma t) -> (forall x. t x -> f (x -> a)) -> f a matchA x pi = (\(Sigma One x) -> x) <$> x <**> pi One -- | An alternative definition of monads, as witnessed by 'bind' and 'matchM'. -- This class is almost like 'Selective' but has no the constraint on @t@. class Applicative f => MonadS f where matchUnconstrained :: f (Sigma t) -> (forall x. t x -> f (x -> a)) -> f a -- Adapted from the original implementation by Daniel Peebles: -- https://gist.github.com/copumpkin/d5bdbc7afda54ff04049b6bdbcffb67e -- | Monadic bind. bind :: MonadS f => f a -> (a -> f b) -> f b bind x f = matchUnconstrained (many <$> x) (\(Many x) -> const <$> f x) -- | Every monad is a multi-way selective functor. matchM :: Monad f => f (Sigma t) -> (forall x. t x -> f (x -> a)) -> f a matchM sigma pi = sigma >>= \case Sigma t x -> ($x) <$> pi t -- | A generalised product type (Pi), which holds an appropriately tagged -- payload @u x@ for every possible tag @t x@. -- -- Note that this looks different than the standard formulation of Pi types. -- Maybe it's just all wrong! -- -- See 'Two', 'pairToPi' and 'piToPair' for an example. type (~>) t u = forall x. t x -> u x infixl 4 ~> -- | A product type where the payload has the type specified with the tag. type Pi t = t ~> Identity -- | A projection from a generalised product. project :: t a -> Pi t -> a project t pi = runIdentity (pi t) -- | A trivial product type that stores nothing and simply returns the given tag -- as the result. identity :: t ~> t identity = id -- | As it turns out, one can compose such generalised products. Why not: given -- a tag, get the payload of the first product and then pass it as input to the -- second. This feels too trivial to be useful but is still somewhat cute. compose :: (u ~> v) -> (t ~> u) -> (t ~> v) compose f g = f . g -- | Update a generalised sum given a generalised product that takes care of all -- possible cases. apply :: (t ~> u) -> Sigma t -> Sigma u apply pi (Sigma t x) = Sigma (pi t) x -- | Encode a value into a generalised sum type that has a single tag 'One'. toSigma :: a -> Sigma (One a) toSigma = inject One -- | Decode a value from a generalised sum type that has a single tag 'One'. fromSigma :: Sigma (One a) -> a fromSigma (Sigma One a) = a -- | Encode a value into a generalised product type that has a single tag 'One'. toPi :: a -> Pi (One a) toPi a One = Identity a -- | Decode a value from a generalised product type that has a single tag 'One'. fromPi :: Pi (One a) -> a fromPi = project One -- | Encode @(a, b)@ into a generalised product type. pairToPi :: (a, b) -> Pi (Two a b) pairToPi (a, b) = \case A -> Identity a B -> Identity b -- | Decode @(a, b)@ from a generalised product type. piToPair :: Pi (Two a b) -> (a, b) piToPair pi = (project A pi, project B pi) -- | Handler of a single case in a generalised pattern matching 'matchCases'. newtype Case f a x = Case { handleCase :: f (x -> a) } -- | Generalised pattern matching on a Sigma type using a Pi type to describe -- how to handle each case. matchCases :: Functor f => Sigma t -> (t ~> Case f a) -> f a matchCases (Sigma t x) pi = ($x) <$> handleCase (pi t) selective-0.7/src/Control/Selective/Rigid/Free.hs0000644000000000000000000001202114374406574020150 0ustar0000000000000000{-# LANGUAGE GADTs, RankNTypes, TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Selective.Rigid.Free -- Copyright : (c) Andrey Mokhov 2018-2023 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- -- This is a library for /selective applicative functors/, or just -- /selective functors/ for short, an abstraction between applicative functors -- and monads, introduced in this paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf. -- -- This module defines /free rigid selective functors/. Rigid selective functors -- are those that satisfy the property @\<*\> = apS@. -- -- Intuitively, a selective functor @f@ is "rigid" if any expression @f a@ is -- equivalent to a list of effects chained with @select@ operators (the normal -- form given by the free construction). In contrast, "non-rigid" selective -- functors can have non-linear, tree-like shapes, because @<*>@ nodes can't be -- straightened using the @\<*\> = apS@ equation. -- ----------------------------------------------------------------------------- module Control.Selective.Rigid.Free ( -- * Free rigid selective functors Select (..), liftSelect, -- * Static analysis getPure, getEffects, getNecessaryEffect, runSelect, foldSelect ) where import Control.Selective.Trans.Except import Control.Selective import Data.Bifunctor import Data.Functor -- Inspired by free applicative functors by Capriotti and Kaposi. -- See: https://arxiv.org/pdf/1403.0749.pdf -- TODO: The current approach is simple but very slow: 'fmap' costs O(N), where -- N is the number of effects, and 'select' is even worse -- O(N^2). It is -- possible to improve both bounds to O(1) by using the idea developed for free -- applicative functors by Dave Menendez. See this blog post: -- https://www.eyrie.org/~zednenem/2013/05/27/freeapp -- An example implementation can be found here: -- http://hackage.haskell.org/package/free/docs/Control-Applicative-Free-Fast.html -- | Free rigid selective functors. data Select f a where Pure :: a -> Select f a Select :: Select f (Either a b) -> f (a -> b) -> Select f b -- TODO: Prove that this is a lawful 'Functor'. instance Functor f => Functor (Select f) where fmap f (Pure a) = Pure (f a) fmap f (Select x y) = Select (fmap f <$> x) (fmap f <$> y) -- TODO: Prove that this is a lawful 'Applicative'. instance Functor f => Applicative (Select f) where pure = Pure (<*>) = apS -- Rigid selective functors -- TODO: Prove that this is a lawful 'Selective'. instance Functor f => Selective (Select f) where -- Identity law select x (Pure y) = either y id <$> x -- Associativity law select x (Select y z) = Select (select (f <$> x) (g <$> y)) (h <$> z) where f = fmap Right g y a = bimap (,a) ($a) y h = uncurry {- The following can be used in the above implementation as select = selectOpt. -- An optimised implementation of select for the free instance. It accumulates -- the calls to fmap on the @y@ parameter to avoid traversing the list on every -- recursive step. selectOpt :: Functor f => Select f (Either a b) -> Select f (a -> b) -> Select f b selectOpt x y = go x y id -- We turn @Select f (a -> b)@ to @(Select f c, c -> (a -> b))@. Hey, co-Yoneda! go :: Functor f => Select f (Either a b) -> Select f c -> (c -> (a -> b)) -> Select f b go x (Pure y) k = either (k y) id <$> x go x (Select y z) k = Select (go (f <$> x) y (g . second k)) ((h . (k.)) <$> z) where f x = Right <$> x g y = \a -> bimap (,a) ($a) y h z = uncurry z -} -- | Lift a functor into a free selective computation. liftSelect :: Functor f => f a -> Select f a liftSelect f = Select (Pure (Left ())) (const <$> f) -- | Given a natural transformation from @f@ to @g@, this gives a canonical -- natural transformation from @Select f@ to @g@. runSelect :: Selective g => (forall x. f x -> g x) -> Select f a -> g a runSelect _ (Pure a) = pure a runSelect t (Select x y) = select (runSelect t x) (t y) -- | Concatenate all effects of a free selective computation. foldSelect :: Monoid m => (forall x. f x -> m) -> Select f a -> m foldSelect f = getOver . runSelect (Over . f) -- | Extract the resulting value if there are no necessary effects. getPure :: Select f a -> Maybe a getPure = runSelect (const Nothing) -- | Collect all possible effects in the order they appear in a free selective -- computation. getEffects :: Functor f => Select f a -> [f ()] getEffects = foldSelect (pure . void) -- Implementation used in the paper: -- getEffects = getOver . runSelect (Over . pure . void) -- | Extract the necessary effect from a free selective computation. Note: there -- can be at most one effect that is statically guaranteed to be necessary. getNecessaryEffect :: Functor f => Select f a -> Maybe (f ()) getNecessaryEffect = leftToMaybe . runExcept . runSelect (throwE . void) leftToMaybe :: Either a b -> Maybe a leftToMaybe (Left a) = Just a leftToMaybe _ = Nothing selective-0.7/src/Control/Selective/Rigid/Freer.hs0000644000000000000000000001007014374406574020334 0ustar0000000000000000{-# LANGUAGE DeriveFunctor, GADTs, RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Selective.Rigid.Freer -- Copyright : (c) Andrey Mokhov 2018-2023 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- -- This is a library for /selective applicative functors/, or just -- /selective functors/ for short, an abstraction between applicative functors -- and monads, introduced in this paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf. -- -- This module defines /freer rigid selective functors/. Rigid selective -- functors are those that satisfy the property @\<*\> = apS@. Compared to the -- "free" construction from "Control.Selective.Rigid.Free", this "freer" -- construction does not require the underlying base data type to be a functor. -- ----------------------------------------------------------------------------- module Control.Selective.Rigid.Freer ( -- * Free rigid selective functors Select (..), liftSelect, -- * Static analysis getPure, getEffects, getNecessaryEffect, runSelect, foldSelect ) where import Control.Selective.Trans.Except import Control.Selective import Data.Bifunctor import Data.Function import Data.Functor -- Inspired by free applicative functors by Capriotti and Kaposi. -- See: https://arxiv.org/pdf/1403.0749.pdf -- Note: In the current implementation, 'fmap' and 'select' cost O(N), where N -- is the number of effects. It is possible to improve this to O(1) by using the -- idea developed for free applicative functors by Dave Menendez, see this blog -- post: https://www.eyrie.org/~zednenem/2013/05/27/freeapp. -- An example implementation can be found here: -- http://hackage.haskell.org/package/free/docs/Control-Applicative-Free-Fast.html -- | Free rigid selective functors. data Select f a where Pure :: a -> Select f a Select :: Select f (Either (x -> a) a) -> f x -> Select f a -- TODO: Prove that this is a lawful 'Functor'. instance Functor (Select f) where fmap f (Pure a) = Pure (f a) fmap f (Select x y) = Select (bimap (f.) f <$> x) y -- O(N) -- TODO: Prove that this is a lawful 'Applicative'. instance Applicative (Select f) where pure = Pure (<*>) = apS -- Rigid selective functors -- TODO: Prove that this is a lawful 'Selective'. instance Selective (Select f) where select = selectBy (first (&)) where selectBy :: (a -> Either (b -> c) c) -> Select f a -> Select f b -> Select f c selectBy f x (Pure y) = either ($y) id . f <$> x selectBy f x (Select y z) = Select (selectBy g x y) z -- O(N) where g a = case f a of Right c -> Right (Right c) Left bc -> Left (bimap (bc.) bc) -- | Lift a functor into a free selective computation. liftSelect :: f a -> Select f a liftSelect = Select (Pure (Left id)) -- | Given a natural transformation from @f@ to @g@, this gives a canonical -- natural transformation from @Select f@ to @g@. runSelect :: Selective g => (forall x. f x -> g x) -> Select f a -> g a runSelect _ (Pure a) = pure a runSelect t (Select x y) = select (runSelect t x) ((&) <$> t y) -- | Concatenate all effects of a free selective computation. foldSelect :: Monoid m => (forall x. f x -> m) -> Select f a -> m foldSelect f = getOver . runSelect (Over . f) -- | Extract the resulting value if there are no necessary effects. getPure :: Select f a -> Maybe a getPure = runSelect (const Nothing) -- | Collect all possible effects in the order they appear in a free selective -- computation. getEffects :: Functor f => Select f a -> [f ()] getEffects = foldSelect (pure . void) -- | Extract the necessary effect from a free selective computation. Note: there -- can be at most one effect that is statically guaranteed to be necessary. getNecessaryEffect :: Functor f => Select f a -> Maybe (f ()) getNecessaryEffect = leftToMaybe . runExcept . runSelect (throwE . void) leftToMaybe :: Either a b -> Maybe a leftToMaybe (Left a) = Just a leftToMaybe _ = Nothing selective-0.7/src/Control/Selective/Trans/Except.hs0000644000000000000000000001176414376571333020563 0ustar0000000000000000{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveTraversable, DerivingVia #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Selective.Trans.Except -- Copyright : (c) Andrey Mokhov 2018-2023 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental -- -- This is a library for /selective applicative functors/, or just -- /selective functors/ for short, an abstraction between applicative functors -- and monads, introduced in this paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf. -- -- This module defines a newtype around 'ExceptT' from @transformers@ with less -- restrictive 'Applicative', 'Selective', and 'Alternative' implementations. -- It supplies an @instance 'Selective' f => 'Selective' ('ExceptT' e f)@, which -- makes 'ExceptT' a bona-fide 'Selective' transformer. -- -- The API follows the API from the @transformers@ package, so it can be used as -- a drop-in replacement. The documentation can be found in the -- [@transformers@](https://hackage.haskell.org/package/transformers/docs/Control-Monad-Trans-Except.html) package. ----------------------------------------------------------------------------- module Control.Selective.Trans.Except where import Control.Applicative (Alternative) import Control.Monad (MonadPlus) import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Zip (MonadZip) import Data.Functor.Classes import Data.Functor.Contravariant (Contravariant) import Data.Functor.Identity #if MIN_VERSION_base(4,13,0) -- MonadFail is imported already #else import Control.Monad.Fail #endif import qualified Control.Monad.Trans.Except as T import Control.Selective import Control.Monad.Signatures -- | A newtype wrapper around 'T.ExceptT' from @transformers@ that provides less -- restrictive 'Applicative', 'Selective' and 'Alternative' instances. newtype ExceptT e f a = ExceptT { unwrap :: T.ExceptT e f a } deriving ( Functor, Foldable, Traversable, Monad, Contravariant, Eq, Ord, Read, Show , MonadFix, MonadFail, MonadZip, MonadIO, MonadPlus, Eq1, Ord1, Read1, Show1 ) deriving (Applicative, Selective, Alternative) via (ComposeEither f e) {- Why don't we provide a `MonadTrans (ExceptT e)` instance? Recall the definition of the MonadTrans type class: class (forall m. Monad m => Monad (t m)) => MonadTrans t where lift :: Monad m => m a -> t m a If we instantiate `t` to `ExceptT e` in the constraint, we get forall m. Monad m => Monad (ExceptT e m) but the `Applicative (ExceptT e m)` instance comes with the `Selective m` constraint, and since Selective is not a superclass of Monad, we're stuck. In other words, `ExceptT` is really not a universal monad transformer: it works only for monads `m` that also happen to have a `Selective m` instance. I can see three possible solutions but none of them has a chance of working in practice: * Change the constraint in the definition of MonadTrans to forall m. (Selective m, Monad m) => Monad (ExceptT e m) * Make Selective a superclass of Monad * Revert the "Applicative is a superclass of Monad" proposal (lol!) And so we just don't provide `MonadTrans (ExceptT e)` instance. We could provide a SelectiveTrans instance instead, where class (forall f. Selective f => Selective (t f)) => SelectiveTrans t where lift :: Selective f => f a -> t f a Sounds fun! -} -- | Inject an 'T.ExceptT' value into the newtype wrapper. wrap :: T.ExceptT e m a -> ExceptT e m a wrap = ExceptT type Except e = ExceptT e Identity except :: Monad m => Either e a -> ExceptT e m a except = ExceptT . T.except runExcept :: Except e a -> Either e a runExcept = T.runExcept . unwrap mapExcept :: (Either e a -> Either e' b) -> Except e a -> Except e' b mapExcept f = ExceptT . T.mapExcept f . unwrap withExcept :: (e -> e') -> Except e a -> Except e' a withExcept f = ExceptT . T.withExcept f . unwrap runExceptT :: ExceptT e m a -> m (Either e a) runExceptT = T.runExceptT . unwrap mapExceptT :: (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b mapExceptT f = ExceptT . T.mapExceptT f . unwrap withExceptT :: Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a withExceptT f = ExceptT . T.withExceptT f . unwrap throwE :: Monad m => e -> ExceptT e m a throwE = ExceptT . T.throwE catchE :: Monad m => ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a catchE action continuation = ExceptT $ T.catchE (unwrap action) (unwrap . continuation) liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b liftCallCC callCC caller = ExceptT $ T.liftCallCC callCC (unwrap . caller . (ExceptT .)) liftListen :: Monad m => Listen w m (Either e a) -> Listen w (ExceptT e m) a liftListen listen (ExceptT action) = ExceptT $ T.liftListen listen action liftPass :: Monad m => Pass w m (Either e a) -> Pass w (ExceptT e m) a liftPass pass (ExceptT action) = ExceptT $ T.liftPass pass action selective-0.7/test/Main.hs0000644000000000000000000005347114374406574013760 0ustar0000000000000000{-# LANGUAGE TypeApplications #-} import Control.Arrow (ArrowMonad) import Control.Monad.Trans.Writer hiding (writer) import Control.Selective.Trans.Except hiding (except) import Control.Selective import Data.Functor.Identity import Data.Maybe hiding (maybe) import Prelude hiding (maybe) import Build import Laws import Validation import Test import qualified Control.Selective.Free as F import qualified Control.Selective.Rigid.Free as FR import qualified Teletype as F import qualified Teletype.Rigid as FR main :: IO () main = runTests $ testGroup "Tests" [ pingPong , build , over , under , validation , arrowMonad , maybe , identity , writer , except ] -------------------------------------------------------------------------------- ------------------------ Ping-pong---------------------------------------------- -------------------------------------------------------------------------------- pingPong :: Tests pingPong = testGroup "pingPong" [ expectSuccess "Free.getEffects pingPongS == [Read,Write \"pong\"]" $ F.getEffects F.pingPongS == [F.Read (const ()),F.Write "pong" ()] , expectSuccess "Free.getNecessaryEffects pingPongS == [Read]" $ F.getNecessaryEffects F.pingPongS == [F.Read (const ())] , expectSuccess "Free.Rigid.getEffects pingPongS == [Read,Write \"pong\"]" $ FR.getEffects FR.pingPongS == [FR.Read (const ()),FR.Write "pong" ()] ] -------------------------------------------------------------------------------- ------------------------ Build ------------------------------------------------- -------------------------------------------------------------------------------- build :: Tests build = testGroup "Build" [ cyclicDeps , taskBindDeps , runBuildDeps ] cyclicDeps :: Tests cyclicDeps = testGroup "cyclicDeps" [ expectSuccess "dependenciesOver (fromJust $ cyclic \"B1\") == [\"C1\",\"B2\",\"A2\"]" $ dependenciesOver (fromJust $ cyclic "B1") == ["C1","B2","A2"] , expectSuccess "dependenciesOver cyclic \"B2\") == [\"C1\",\"A1\",\"B1\"]" $ dependenciesOver (fromJust $ cyclic "B2") == ["C1","A1","B1"] , expectSuccess "dependenciesUnder (fromJust $ cyclic \"B1\") == [\"C1\"]" $ dependenciesUnder (fromJust $ cyclic "B1") == ["C1"] , expectSuccess "dependenciesUnder cyclic \"B2\") == [\"C1\"]" $ dependenciesUnder (fromJust $ cyclic "B2") == ["C1"] ] taskBindDeps :: Tests taskBindDeps = testGroup "taskBindDeps" [ expectSuccess "dependenciesOver taskBind == [\"A1\",\"A2\",\"C5\",\"C6\",\"A2\",\"D5\",\"D6\"]" $ dependenciesOver taskBind == ["A1","A2","C5","C6","A2","D5","D6"] , expectSuccess "dependenciesUnder taskBind == [\"A1\"]" $ dependenciesUnder taskBind == ["A1"] ] runBuildDeps :: Tests runBuildDeps = testGroup "runBuildDeps" [ expectSuccess "runBuild (fromJust $ cyclic \"B1\") == [Fetch \"C1\",Fetch \"B2\",Fetch \"A2\"]" $ runBuild (fromJust $ cyclic "B1") == [Fetch "C1" (const ()),Fetch "B2" (const ()),Fetch "A2" (const ())] ] -------------------------------------------------------------------------------- ------------------------ Over -------------------------------------------------- -------------------------------------------------------------------------------- over :: Tests over = testGroup "Over" [ overLaws , overTheorems , overProperties ] overLaws :: Tests overLaws = testGroup "Laws" [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @(Over String) x , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @(Over String) @Int @Int x , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @(Over String) @Int @Int x ] overTheorems :: Tests overTheorems = testGroup "Theorems" [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @(Over String) @Int @Int x , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @(Over String) @Int @Int @Int x , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @(Over String) @Int @Int @Int x , expectSuccess "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @(Over String) @Int @Int x , expectSuccess "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @(Over String) @Int @Int x , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @(Over String) @Int @Int x ] overProperties :: Tests overProperties = testGroup "Properties" [ expectFailure "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @(Over String) @Int @Int x , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @(Over String) @Int @Int x ] -------------------------------------------------------------------------------- ------------------------ Under ------------------------------------------------- -------------------------------------------------------------------------------- under :: Tests under = testGroup "Under" [ underLaws , underTheorems , underProperties ] underLaws :: Tests underLaws = testGroup "Laws" [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @(Under String) x , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @(Under String) @Int @Int x , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @(Under String) @Int @Int x ] underTheorems :: Tests underTheorems = testGroup "Theorems" [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @(Under String) @Int @Int x , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @(Under String) @Int @Int @Int x , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @(Under String) @Int @Int @Int x , expectSuccess "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @(Under String) @Int @Int x -- 'Under' is a non-rigid selective functor , expectFailure "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @(Under String) @Int @Int x , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @(Under String) @Int @Int x ] underProperties :: Tests underProperties = testGroup "Properties" [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @(Under String) @Int @Int x , expectFailure "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @(Under String) @Int @Int x ] -------------------------------------------------------------------------------- ------------------------ Validation -------------------------------------------- -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- validation :: Tests validation = testGroup "Validation" [ validationLaws , validationTheorems , validationProperties , validationExample ] validationLaws :: Tests validationLaws = testGroup "Laws" [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @(Validation String) @Int x , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @(Validation String) @Int @Int x , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @(Validation String) @Int @Int @Int x ] validationTheorems :: Tests validationTheorems = testGroup "Theorems" [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @(Validation String) @Int @Int @Int x , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @(Validation String) @Int @Int @Int x , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @(Validation String) @Int @Int @Int x , expectSuccess "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @(Validation String) @Int @Int x -- 'Validation' is a non-rigid selective functor , expectFailure "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @(Validation String) @Int @Int x -- 'Validation' is a non-rigid selective functor , expectFailure "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @(Validation String) @Int @Int @Int x ] validationProperties :: Tests validationProperties = testGroup "Properties" [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @(Validation String) @Int @Int x , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @(Validation String) @Int @Int x ] validationExample :: Tests validationExample = testGroup "validationExample" [ expectSuccess "shape (Success True) (Success 1) (Failure [\"width?\"]) (Failure [\"height?\"])" $ shape (Success True) (Success 1) (Failure ["width?"]) (Failure ["height?"]) == Success (Circle 1) , expectSuccess "shape (Success False) (Failure [\"radius?\"]) (Success 2) (Success 3)" $ shape (Success False) (Failure ["radius?"]) (Success 2) (Success 3) == Success (Rectangle 2 3) , expectSuccess "shape (Success False) (Failure [\"radius?\"]) (Success 2) (Failure [\"height?\"])" $ shape (Success False) (Failure ["radius?"]) (Success 2) (Failure ["height?"]) == Failure ["height?"] , expectSuccess "shape (Success False) (Success 1) (Failure [\"width?\"]) (Failure [\"height?\"])" $ shape (Success False) (Success 1) (Failure ["width?"]) (Failure ["height?"]) == Failure ["width?", "height?"] , expectSuccess "shape (Failure [\"choice?\"]) (Failure [\"radius?\"]) (Success 2) (Failure [\"height?\"])" $ shape (Failure ["choice?"]) (Failure ["radius?"]) (Success 2) (Failure ["height?"]) == Failure ["choice?"] , expectSuccess "twoShapes s1 s2" $ twoShapes (shape (Failure ["choice 1?"]) (Success 1) (Failure ["width 1?"]) (Success 3)) (shape (Success False) (Success 1) (Success 2) (Failure ["height 2?"])) == Failure ["choice 1?","height 2?"] ] -------------------------------------------------------------------------------- ------------------------ ArrowMonad -------------------------------------------- -------------------------------------------------------------------------------- arrowMonad :: Tests arrowMonad = testGroup "ArrowMonad (->)" [ arrowMonadLaws , arrowMonadTheorems , arrowMonadProperties ] arrowMonadLaws :: Tests arrowMonadLaws = testGroup "Laws" [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @(ArrowMonad (->)) @Int x , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @(ArrowMonad (->)) @Int @Int x , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @(ArrowMonad (->)) @Int @Int @Int x , expectSuccess "select == selectM" $ \x -> lawMonad @(ArrowMonad (->)) @Int @Int x , expectSuccess "select == selectA" $ \x -> selectALaw @(ArrowMonad (->)) @Int @Int x ] arrowMonadTheorems :: Tests arrowMonadTheorems = testGroup "Theorems" [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @(ArrowMonad (->)) @Int @Int @Int x , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @(ArrowMonad (->)) @Int @Int @Int x , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @(ArrowMonad (->)) @Int @Int @Int x , expectSuccess "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @(ArrowMonad (->)) @Int @Int x , expectSuccess "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @(ArrowMonad (->)) @Int @Int x , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @(ArrowMonad (->)) @Int @Int @Int x ] arrowMonadProperties :: Tests arrowMonadProperties = testGroup "Properties" [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @(ArrowMonad (->)) @Int @Int x , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @(ArrowMonad (->)) @Int @Int x ] -------------------------------------------------------------------------------- ------------------------ Maybe ------------------------------------------------- -------------------------------------------------------------------------------- maybe :: Tests maybe = testGroup "Maybe" [ maybeLaws , maybeTheorems , maybeProperties ] maybeLaws :: Tests maybeLaws = testGroup "Laws" [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @Maybe @Int x , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @Maybe @Int @Int x , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @Maybe @Int @Int @Int x , expectSuccess "select == selectM" $ \x -> lawMonad @Maybe @Int @Int x ] maybeTheorems :: Tests maybeTheorems = testGroup "Theorems" [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @Maybe @Int @Int @Int x , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @Maybe @Int @Int @Int x , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @Maybe @Int @Int @Int x , expectSuccess "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @Maybe @Int @Int x , expectSuccess "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @Maybe @Int @Int x , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @Maybe @Int @Int @Int x ] maybeProperties :: Tests maybeProperties = testGroup "Properties" [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @Maybe @Int @Int x , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @Maybe @Int @Int x ] -------------------------------------------------------------------------------- ------------------------ Identity ---------------------------------------------- -------------------------------------------------------------------------------- identity :: Tests identity = testGroup "Identity" [ identityLaws , identityTheorems , identityProperties ] identityLaws :: Tests identityLaws = testGroup "Laws" [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @Identity @Int x , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @Identity @Int @Int x , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @Identity @Int @Int @Int x , expectSuccess "select == selectM" $ \x -> lawMonad @Identity @Int @Int x ] identityTheorems :: Tests identityTheorems = testGroup "Theorems" [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @Identity @Int @Int @Int x , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @Identity @Int @Int @Int x , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @Identity @Int @Int @Int x , expectSuccess "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @Identity @Int @Int x , expectSuccess "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @Identity @Int @Int x , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @Identity @Int @Int @Int x ] identityProperties :: Tests identityProperties = testGroup "Properties" [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @Identity @Int @Int x , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @Identity @Int @Int x ] -------------------------------------------------------------------------------- ------------------------ Writer ------------------------------------------------ -------------------------------------------------------------------------------- writer :: Tests writer = testGroup "Writer" [ writerLaws , writerTheorems , writerProperties ] type MyWriter = Writer [Int] writerLaws :: Tests writerLaws = testGroup "Laws" [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @MyWriter @Int x , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @MyWriter @Int @Int x , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @MyWriter @Int @Int @Int x , expectSuccess "select == selectM" $ \x -> lawMonad @MyWriter @Int @Int x ] writerTheorems :: Tests writerTheorems = testGroup "Theorems" [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @MyWriter @Int @Int @Int x , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @MyWriter @Int @Int @Int x , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @MyWriter @Int @Int @Int x , expectSuccess "Generalised Identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @MyWriter @Int @Int x , expectSuccess "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @MyWriter @Int @Int x , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @MyWriter @Int @Int @Int x ] writerProperties :: Tests writerProperties = testGroup "Properties" [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @MyWriter @Int @Int x , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @MyWriter @Int @Int x ] -------------------------------------------------------------------------------- ------------------------ Except ------------------------------------------------ -------------------------------------------------------------------------------- except :: Tests except = testGroup "Except" [ exceptLaws , exceptTheorems , exceptProperties ] type MyExcept = Except [Int] exceptLaws :: Tests exceptLaws = testGroup "Laws" [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @MyExcept @Int x , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @MyExcept @Int @Int x , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @MyExcept @Int @Int @Int x , expectSuccess "select == selectM" $ \x -> lawMonad @MyExcept @Int @Int x ] exceptTheorems :: Tests exceptTheorems = testGroup "Theorems" [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @MyExcept @Int @Int @Int x , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @MyExcept @Int @Int @Int x , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @MyExcept @Int @Int @Int x , expectSuccess "Generalised Identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @MyExcept @Int @Int x , expectSuccess "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @MyExcept @Int @Int x , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @MyExcept @Int @Int @Int x ] exceptProperties :: Tests exceptProperties = testGroup "Properties" [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @MyExcept @Int @Int x , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @MyExcept @Int @Int x ] selective-0.7/examples/Build.hs0000644000000000000000000001013014374406574014753 0ustar0000000000000000{-# LANGUAGE ConstraintKinds, DeriveFunctor, FlexibleInstances, GADTs, RankNTypes #-} module Build where import Control.Selective import Control.Selective.Rigid.Free -- See Section 3 of the paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf -- | Selective build tasks. -- See "Build Systems à la Carte": https://dl.acm.org/citation.cfm?id=3236774. newtype Task k v = Task { run :: forall f. Selective f => (k -> f v) -> f v } -- | Selective build scripts. type Script k v = k -> Maybe (Task k v) -- | Build dependencies with over-approximation. dependenciesOver :: Task k v -> [k] dependenciesOver task = getOver $ run task (\k -> Over [k]) -- | Build dependencies with under-approximation. dependenciesUnder :: Task k v -> [k] dependenciesUnder task = getUnder $ run task (\k -> Under [k]) -- | A build script with a static dependency cycle, which always resolves into -- an acyclic dependency graph in runtime. -- -- @ -- 'dependenciesOver' ('fromJust' $ 'cyclic' "B1") == ["C1","B2","A2"] -- 'dependenciesOver' ('fromJust' $ 'cyclic' "B2") == ["C1","A1","B1"] -- 'dependenciesUnder' ('fromJust' $ 'cyclic' "B1") == ["C1"] -- 'dependenciesUnder' ('fromJust' $ 'cyclic' "B2") == ["C1"] -- @ cyclic :: Script String Integer cyclic "B1" = Just $ Task $ \fetch -> ifS ((1==) <$> fetch "C1") (fetch "B2") (fetch "A2") cyclic "B2" = Just $ Task $ \fetch -> ifS ((1==) <$> fetch "C1") (fetch "A1") (fetch "B1") cyclic _ = Nothing -- | A build task demonstrating the use of 'bindS'. -- -- @ -- 'dependenciesOver' 'taskBind' == ["A1","A2","C5","C6","D5","D6"] -- 'dependenciesUnder' 'taskBind' == ["A1"] -- @ taskBind :: Task String Integer taskBind = Task $ \fetch -> (odd <$> fetch "A1") `bindS` \x -> (odd <$> fetch "A2") `bindS` \y -> let c = if x then "C" else "D" n = if y then "5" else "6" in fetch (c ++ n) data Key = A Int | B Int | C Int Int deriving (Eq, Show) editDistance :: Script Key Int editDistance (C i 0) = Just $ Task $ const $ pure i editDistance (C 0 j) = Just $ Task $ const $ pure j editDistance (C i j) = Just $ Task $ \fetch -> ((==) <$> fetch (A i) <*> fetch (B j)) `bindS` \equals -> if equals then fetch (C (i - 1) (j - 1)) else (\insert delete replace -> 1 + minimum [insert, delete, replace]) <$> fetch (C i (j - 1)) <*> fetch (C (i - 1) j ) <*> fetch (C (i - 1) (j - 1)) editDistance _ = Nothing -- | Example from the paper: a mock for the @tar@ archiving utility. tar :: Applicative f => [f String] -> f String tar xs = concat <$> sequenceA xs -- | Example from the paper: a mock for the configuration parser. parse :: Functor f => f String -> f Bool parse = fmap null -- | Example from the paper: a mock for the OCaml compiler parser. compile :: Applicative f => [f String] -> f String compile xs = concat <$> sequenceA xs -- | Example from the paper. script :: Script FilePath String script "release.tar" = Just $ Task $ \fetch -> tar [fetch "LICENSE", fetch "exe"] script "exe" = Just $ Task $ \fetch -> let src = fetch "src.ml" cfg = fetch "config" libc = fetch "lib.c" libml = fetch "lib.ml" in compile [src, ifS (parse cfg) libc libml] script _ = Nothing --------------------------------- Free example --------------------------------- -- | Base functor for a free build system. data Fetch k v a = Fetch k (v -> a) deriving Functor instance Eq k => Eq (Fetch k v ()) where Fetch x _ == Fetch y _ = x == y instance Show k => Show (Fetch k v a) where show (Fetch k _) = "Fetch " ++ show k -- | A convenient alias. fetch :: k -> Select (Fetch k v) v fetch key = liftSelect $ Fetch key id -- | Analyse a build task via free selective functors. -- -- @ -- runBuild (fromJust $ cyclic "B1") == [ Fetch "C1" (const ()) -- , Fetch "B2" (const ()) -- , Fetch "A2" (const ()) ] -- @ runBuild :: Task k v -> [Fetch k v ()] runBuild task = getEffects (run task fetch) selective-0.7/test/Laws.hs0000644000000000000000000001577314374406574014005 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TupleSections, TypeApplications #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Laws where import Control.Arrow hiding (first, second) import qualified Control.Monad.Trans.Except as Transformers import Control.Monad.Trans.Writer import Control.Selective import Control.Selective.Trans.Except import Data.Bifunctor (bimap, first, second) import Data.Function import Data.Functor.Identity import Test.QuickCheck hiding (Failure, Success) import Text.Show.Functions() -- | TODO: -- ifS (pure x) a1 b1 *> ifS (pure x) a2 b2 = ifS (pure x) (a1 *> a2) (b1 *> b2) -------------------------------------------------------------------------------- ------------------------ Laws -------------------------------------------------- -------------------------------------------------------------------------------- -- | Identity lawIdentity :: (Selective f, Eq (f a)) => f (Either a a) -> Bool lawIdentity x = (x <*? pure id) == (either id id <$> x) -- | Distributivity lawDistributivity :: (Selective f, Eq (f b)) => Either a b -> f (a -> b) -> f (a -> b) -> Bool lawDistributivity x y z = (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z)) -- | Associativity lawAssociativity :: (Selective f, Eq (f c)) => f (Either b c) -> f (Either a (b -> c)) -> f (a -> b -> c) -> Bool lawAssociativity x y z = (x <*? (y <*? z)) == ((f <$> x) <*? (g <$> y) <*? (h <$> z)) where f = fmap Right g y a = bimap (,a) ($a) y h = uncurry {- | If 'f' is a 'Monad' |-} lawMonad :: (Selective f, Monad f, Eq (f b)) => f (Either a b) -> f (a -> b) -> Bool lawMonad x f = select x f == selectM x f selectALaw :: (Selective f, Eq (f b)) => f (Either a b) -> f (a -> b) -> Bool selectALaw x f = select x f == selectA x f -------------------------------------------------------------------------------- ------------------------ Theorems ---------------------------------------------- -------------------------------------------------------------------------------- {-| Theorems about selective applicative functors, see Fig. 4 of the paper |-} -- | Apply a pure function to the result: theorem1 :: (Selective f, Eq (f c)) => (a -> c) -> f (Either b a) -> f (b -> a) -> Bool theorem1 f x y = (f <$> select x y) == select (second f <$> x) ((f .) <$> y) -- | Apply a pure function to the Left case of the first argument: theorem2 :: (Selective f, Eq (f c)) => (a -> b) -> f (Either a c) -> f (b -> c) -> Bool theorem2 f x y = select (first f <$> x) y == select x ((. f) <$> y) -- | Apply a pure function to the second argument: theorem3 :: (Selective f, Eq (f c)) => (a -> b -> c) -> f (Either b c) -> f a -> Bool theorem3 f x y = select x (f <$> y) == select (first (flip f) <$> x) ((&) <$> y) -- | Generalised identity: theorem4 :: (Selective f, Eq (f b)) => f (Either a b) -> (a -> b) -> Bool theorem4 x y = (x <*? pure y) == (either y id <$> x) {-| For rigid selective functors (in particular, for monads) |-} -- | Selective apply theorem5 :: (Selective f, Eq (f b)) => f (a -> b) -> f a -> Bool theorem5 f g = (f <*> g) == (f `apS` g) -- | Interchange theorem6 :: (Selective f, Eq (f c)) => f a -> f (Either b c) -> f (b -> c) -> Bool theorem6 x y z = (x *> (y <*? z)) == ((x *> y) <*? z) -------------------------------------------------------------------------------- ------------------------ Properties ---------------------------------------------- -------------------------------------------------------------------------------- -- | Pure-Right: pure (Right x) <*? y = pure x propertyPureRight :: (Selective f, Eq (f a)) => a -> f (b -> a) -> Bool propertyPureRight x y = (pure (Right x) <*? y) == pure x -- | Pure-Left: pure (Left x) <*? y = ($x) <$> y propertyPureLeft :: (Selective f, Eq (f b)) => a -> f (a -> b) -> Bool propertyPureLeft x y = (pure (Left x) <*? y) == (($x) <$> y) -------------------------------------------------------------------------------- ------------------------ Over -------------------------------------------------- -------------------------------------------------------------------------------- instance Arbitrary a => Arbitrary (Over a b) where arbitrary = Over <$> arbitrary shrink = map Over . shrink . getOver propertyPureRightOver :: IO () propertyPureRightOver = quickCheck (propertyPureRight @(Over String) @Int) -------------------------------------------------------------------------------- ------------------------ Under ------------------------------------------------- -------------------------------------------------------------------------------- instance Arbitrary a => Arbitrary (Under a b) where arbitrary = Under <$> arbitrary shrink = map Under . shrink . getUnder propertyPureRightUnder :: IO () propertyPureRightUnder = quickCheck (propertyPureRight @(Under String) @Int) -------------------------------------------------------------------------------- ------------------------ Validation -------------------------------------------- -------------------------------------------------------------------------------- instance (Arbitrary e, Arbitrary a) => Arbitrary (Validation e a) where arbitrary = oneof [Failure <$> arbitrary, Success <$> arbitrary] shrink (Failure x) = [ Failure x' | x' <- shrink x ] shrink (Success y) = [ Success y' | y' <- shrink y ] -------------------------------------------------------------------------------- ------------------------ ArrowMonad -------------------------------------------- -------------------------------------------------------------------------------- instance Eq a => Eq (ArrowMonad (->) a) where ArrowMonad f == ArrowMonad g = f () == g () instance Arbitrary a => Arbitrary (ArrowMonad (->) a) where arbitrary = ArrowMonad . const <$> arbitrary instance Show a => Show (ArrowMonad (->) a) where show (ArrowMonad f) = show (f ()) -------------------------------------------------------------------------------- ------------------------ Maybe ------------------------------------------------- -------------------------------------------------------------------------------- propertyPureRightMaybe :: IO () propertyPureRightMaybe = quickCheck (propertyPureRight @Maybe @Int @Int) -------------------------------------------------------------------------------- ------------------------ Identity ---------------------------------------------- -------------------------------------------------------------------------------- propertyPureRightIdentity :: IO () propertyPureRightIdentity = quickCheck (propertyPureRight @Identity @Int @Int) -------------------------------------------------------------------------------- ------------------------ Writer ------------------------------------------------ -------------------------------------------------------------------------------- instance (Arbitrary w, Arbitrary a) => Arbitrary (Writer w a) where arbitrary = curry writer <$> arbitrary <*> arbitrary deriving instance (Arbitrary e, Arbitrary a) => Arbitrary (Transformers.Except e a) deriving instance (Arbitrary e, Arbitrary a) => Arbitrary (Except e a) selective-0.7/examples/Parser.hs0000644000000000000000000000273314374406574015162 0ustar0000000000000000{-# LANGUAGE ConstraintKinds, GADTs, LambdaCase, RankNTypes #-} module Parser where import Control.Applicative import Control.Monad import Control.Selective -- See Section 7.2 of the paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf newtype Parser a = Parser { parse :: String -> [(a, String)] } instance Functor Parser where fmap f p = Parser $ \x -> [ (f a, s) | (a, s) <- parse p x ] instance Applicative Parser where pure a = Parser $ \s -> [(a, s)] (<*>) = ap instance Alternative Parser where empty = Parser (const []) p <|> q = Parser $ \s -> parse p s ++ parse q s instance Selective Parser where select = selectM instance Monad Parser where return = pure p >>= f = Parser $ \x -> concat [ parse (f a) y | (a, y) <- parse p x ] class MonadZero f where zero :: f a instance MonadZero Parser where zero = Parser (const []) item :: Parser Char item = Parser $ \case "" -> [] (c:cs) -> [(c,cs)] sat :: (Char -> Bool) -> Parser Char sat p = do { c <- item; if p c then pure c else zero } char :: Char -> Parser Char char c = sat (==c) string :: String -> Parser String string [] = pure "" string (c:cs) = do _ <- char c _ <- string cs pure (c:cs) bin :: Parser Int bin = undefined hex :: Parser Int hex = undefined numberA :: Parser Int numberA = (string "0b" *> bin) <|> (string "0x" *> hex) numberS :: Parser Int numberS = string "0" *> ifS (('b'==) <$> sat (`elem` "bx")) bin hex selective-0.7/examples/Processor.hs0000644000000000000000000002520314374406574015702 0ustar0000000000000000{-# LANGUAGE ConstraintKinds, DeriveFunctor, GADTs, LambdaCase #-} {-# LANGUAGE FunctionalDependencies, FlexibleContexts, FlexibleInstances #-} module Processor where import Control.Selective import Control.Selective.Rigid.Free import Data.Bool import Data.Functor import Data.Int (Int16) import Data.Map.Strict (Map) import Data.Word (Word8) import Foreign.Marshal.Utils (fromBool) import Prelude hiding (read, log) import qualified Control.Monad.Trans.State as S import qualified Data.Map.Strict as Map -- See Section 5.3 of the paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf -- Note that we have changed the naming. -- | A standard @MonadState@ class extended with the 'Selective' interface. class (Selective m, Monad m) => MonadState s m | m -> s where get :: m s put :: s -> m () state :: (s -> (a, s)) -> m a instance Monad m => MonadState s (S.StateT s m) where get = S.get put = S.put state = S.state gets :: MonadState s m => (s -> a) -> m a gets f = f <$> get modify :: MonadState s m => (s -> s) -> m () modify f = state (\s -> ((), f s)) -------------------------------------------------------------------------------- -------- Types ----------------------------------------------------------------- -------------------------------------------------------------------------------- -- | All values are signed 16-bit words. type Value = Int16 -- | The processor has four registers. data Register = R0 | R1 | R2 | R3 deriving (Show, Eq, Ord) -- | The register bank maps registers to values. type RegisterBank = Map Register Value -- | The address space is indexed by one byte. type Address = Word8 -- | The memory maps addresses to signed 16-bit words. type Memory = Map.Map Address Value -- | The processor has two status flags. data Flag = Zero -- ^ tracks if the result of the last arithmetical operation was zero | Overflow -- ^ tracks integer overflow deriving (Show, Eq, Ord) -- | A flag assignment. type Flags = Map Flag Value -- | Address in the program memory. type InstructionAddress = Value -- | A program execution log entry, recording either a read from a key and the -- obtained value, or a write to a key, along with the written value. data LogEntry k v where ReadEntry :: k -> v -> LogEntry k v WriteEntry :: k -> v -> LogEntry k v -- | A log is a sequence of log entries, in the execution order. type Log k v = [LogEntry k v] -- | The complete processor state. data State = State { registers :: RegisterBank , memory :: Memory , pc :: InstructionAddress , flags :: Flags , log :: Log Key Value} -- | Various elements of the processor state. data Key = Reg Register | Cell Address | Flag Flag | PC deriving Eq instance Show Key where show (Reg r) = show r show (Cell a) = show a show (Flag f) = show f show PC = "PC" -- | The base functor for mutable processor state. data RW a = Read Key (Value -> a) | Write Key (Program Value) (Value -> a) deriving Functor -- | A program is a free selective on top of the 'RW' base functor. type Program a = Select RW a instance Show (RW a) where show (Read k _) = "Read " ++ show k show (Write k (Pure v) _) = "Write " ++ show k ++ " " ++ show v show (Write k _ _) = "Write " ++ show k logEntry :: MonadState State m => LogEntry Key Value -> m () logEntry item = modify $ \s -> s { log = log s ++ [item] } -- | Interpret the base functor in a 'MonadState'. toState :: MonadState State m => RW a -> m a toState = \case (Read k t) -> do v <- case k of Reg r -> gets ((Map.! r) . registers) Cell addr -> gets ((Map.! addr) . memory) Flag f -> gets ((Map.! f) . flags) PC -> gets pc logEntry (ReadEntry k v) pure (t v) (Write k p t) -> do v <- runSelect toState p logEntry (WriteEntry k v) case k of Reg r -> let regs' s = Map.insert r v (registers s) in state (\s -> (t v, s {registers = regs' s})) Cell addr -> let mem' s = Map.insert addr v (memory s) in state (\s -> (t v, s {memory = mem' s})) Flag f -> let flags' s = Map.insert f v (flags s) in state (\s -> (t v, s {flags = flags' s})) PC -> state (\s -> (t v, s {pc = v})) -- | Interpret a program as a state transformer. runProgramState :: Program a -> State -> (a, State) runProgramState f = S.runState (runSelect toState f) -- | Interpret the base functor in the selective functor 'Over'. toOver :: RW a -> Over [RW ()] a toOver (Read k _ ) = Over [Read k (const ())] toOver (Write k fv _) = runSelect toOver fv *> Over [Write k fv (const ())] -- | Get all possible program effects. getProgramEffects :: Program a -> [RW ()] getProgramEffects = getOver . runSelect toOver -- | A convenient alias for reading an element of the processor state. read :: Key -> Program Value read k = liftSelect (Read k id) -- | A convenient alias for writing into an element of the processor state. write :: Key -> Program Value -> Program Value write k fv = liftSelect (Write k fv id) -------------------------------------------------------------------------------- -------- Instructions ---------------------------------------------------------- -------------------------------------------------------------------------------- -- | The addition instruction, which reads the summands from a 'Register' and a -- memory 'Address', adds them, writes the result back into the same register, -- and also updates the state of the 'Zero' flag to indicate whether the -- resulting 'Value' is zero. add :: Register -> Address -> Program Value add reg addr = let arg1 = read (Reg reg) arg2 = read (Cell addr) result = (+) <$> arg1 <*> arg2 isZero = (==0) <$> write (Reg reg) result in write (Flag Zero) (bool 0 1 <$> isZero) -- | A conditional branching instruction that performs a jump if the result of -- the previous operation was zero. jumpZero :: Value -> Program () jumpZero offset = let zeroSet = (==1) <$> read (Flag Zero) modifyPC = void $ write PC ((+offset) <$> read PC) in whenS zeroSet modifyPC -- | A simple block of instructions. addAndJump :: Program () addAndJump = add R0 1 *> jumpZero 42 ----------------------------------- -- Add with overflow tracking ----- ----------------------------------- {- The following example demonstrates how important it is to be aware of your effects. Problem: implement the semantics of the @add@ instruction which calculates the sum of two values and writes it to the specified destination, updates the 'Zero' flag if the result is zero, and also detects if integer overflow has occurred, updating the 'Overflow' flag accordingly. We'll take a look at two approaches that implement this semantics and see the crucial deference between them. -} -- | Add two values and detect integer overflow. -- -- The interesting bit here is the call to the 'willOverflowPure' function. -- Since the function is pure, the call @willOverflowPure <$> arg1 <*> arg2@ -- triggers only one 'read' of @arg1@ and @arg2@, even though we use the -- variables many times in the 'willOverflowPure' implementation. Thus, -- 'willOverflowPure' might be thought as an atomic processor microcommand. addOverflow :: Key -> Key -> Key -> Program Value addOverflow x y z = let arg1 = read x arg2 = read y result = (+) <$> arg1 <*> arg2 isZero = (==0) <$> write z result overflow = willOverflowPure <$> arg1 <*> arg2 in write (Flag Zero) (fromBool <$> isZero) *> write (Flag Overflow) (fromBool <$> overflow) -- | A pure check for integer overflow during addition. willOverflowPure :: Value -> Value -> Bool willOverflowPure x y = let o1 = (>) y 0 o2 = (>) x((-) maxBound y) o3 = (<) y 0 o4 = (<) x((-) minBound y) in (||) ((&&) o1 o2) ((&&) o3 o4) -- | Add two values and detect integer overflow. -- -- In this implementations we take a different approach and, when implementing -- overflow detection, lift all the pure operations into 'Applicative'. This -- forces the semantics to read the input variables more times than -- 'addOverflow' does (@x@ is read 3x times, and @y@ is read 5x times). addOverflowNaive :: Key -> Key -> Key -> Program Value addOverflowNaive x y z = let arg1 = read x arg2 = read y result = (+) <$> arg1 <*> arg2 isZero = (==0) <$> write z result overflow = willOverflow arg1 arg2 in write (Flag Zero) (fromBool <$> isZero) *> write (Flag Overflow) (fromBool <$> overflow) -- | An 'Applicative' check for integer overflow during addition. willOverflow :: Program Value -> Program Value -> Program Bool willOverflow arg1 arg2 = let o1 = (>) <$> arg2 <*> pure 0 o2 = (>) <$> arg1 <*> ((-) maxBound <$> arg2) o3 = (<) <$> arg2 <*> pure 0 o4 = (<) <$> arg1 <*> ((-) minBound <$> arg2) in (||) <$> ((&&) <$> o1 <*> o2) <*> ((&&) <$> o3 <*> o4) ----------------------------------- -- Example simulations ------------ ----------------------------------- renderState :: State -> String renderState state = "Registers: " ++ show (registers state) ++ "\n" ++ "Flags: " ++ show (Map.toList $ flags state) ++ "\n" ++ "Log: " ++ show (log state) instance Show State where show = renderState emptyRegisters :: RegisterBank emptyRegisters = Map.fromList [(R0, 0), (R1, 0), (R2, 0), (R3, 0)] emptyFlags :: Flags emptyFlags = Map.fromList $ zip [Zero, Overflow] [0, 0..] initialiseMemory :: [(Address, Value)] -> Memory initialiseMemory m = let blankMemory = Map.fromList $ zip [0..maxBound] [0, 0..] in foldr (\(addr, value) acc -> Map.adjust (const value) addr acc) blankMemory m boot :: Memory -> State boot mem = State { registers = emptyRegisters , pc = 0 , flags = emptyFlags , memory = mem , log = [] } twoAdds :: Program Value twoAdds = add R0 0 *> add R0 0 addExample :: IO () addExample = do let initState = boot (initialiseMemory [(0, 2)]) print . snd $ runProgramState twoAdds initState ---------------------------- Some boilerplate code ----------------------------- instance (Show k, Show v) => Show (LogEntry k v) where show (ReadEntry k v) = "Read (" ++ show k ++ ", " ++ show v ++ ")" show (WriteEntry k v) = "Write (" ++ show k ++ ", " ++ show v ++ ")" selective-0.7/examples/Query.hs0000644000000000000000000000356314374406574015035 0ustar0000000000000000{-# LANGUAGE GADTs #-} module Query where import Control.Selective import Data.List (isInfixOf, stripPrefix) type Prompt = String data Query a where Terminal :: Prompt -> Query String File :: FilePath -> Query String Pure :: a -> Query a Apply :: Query (a -> b) -> Query a -> Query b Select :: Query (Either a b) -> Query (a -> b) -> Query b instance Functor Query where fmap f = Apply (Pure f) instance Applicative Query where pure = Pure (<*>) = Apply instance Selective Query where select = Select pureQuery :: Query String pureQuery = (++) <$> Pure "Hello " <*> Pure "World!" replace :: String -> String -> String -> String replace [] _ xs = xs replace from to xs | Just xs <- stripPrefix from xs = to ++ replace from to xs replace from to (x:xs) = x : replace from to xs replace _ _ [] = [] welcomeQuery :: Query String welcomeQuery = replace "[NAME]" <$> Terminal "Name" <*> File "welcome.txt" welcomeBackQuery :: Query String welcomeBackQuery = (++) <$> welcomeQuery <*> pure "It's great to have you back!\n" welcomeQuery2 :: Query String welcomeQuery2 = ifS (isInfixOf <$> Terminal "Name" <*> File "past-participants.txt") welcomeBackQuery welcomeQuery getPure :: Query a -> Maybe a getPure (Terminal _) = Nothing getPure (File _) = Nothing getPure (Pure a) = Just a getPure (Apply f x) = do pf <- getPure f px <- getPure x pure (pf px) getPure (Select x y) = do px <- getPure x py <- getPure y pure (either py id px) getEffects :: Query a -> ([Prompt], [FilePath]) getEffects (Terminal p) = ([p], [] ) getEffects (File f) = ([] , [f]) getEffects (Pure _) = ([] , [] ) getEffects (Apply f x) = (p1 ++ p2, f1 ++ f2) where (p1, f1) = getEffects f (p2, f2) = getEffects x getEffects (Select x y) = (px ++ py, fx ++ fy) where (px, fx) = getEffects x (py, fy) = getEffects y selective-0.7/test/Sketch.hs0000644000000000000000000005777314374406574014326 0ustar0000000000000000{-# LANGUAGE DeriveFunctor, EmptyCase, FlexibleInstances, GADTs, RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TupleSections #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} module Sketch where import Control.Arrow hiding (first, second) import Control.Category (Category) import Control.Monad import Control.Selective import Data.Bifunctor import Data.Bool import Data.Function import Data.Semigroup (Semigroup (..)) import Data.Void import qualified Control.Arrow as A import qualified Control.Category as C -- This file contains various examples and proof sketches and we keep it here to -- make sure it still compiles. We ignore HLINT suggestions because they often -- get in the way of readable "proofs" that use equational reasoning. {-# ANN module "HLint: ignore" #-} ------------------------------- Various examples ------------------------------- bindBool :: Selective f => f Bool -> (Bool -> f a) -> f a bindBool x f = ifS x (f False) (f True) branch3 :: Selective f => f (Either a (Either b c)) -> f (a -> d) -> f (b -> d) -> f (c -> d) -> f d branch3 x a b c = (fmap (fmap Left) <$> x) <*? (fmap (Right . Right) <$> a) <*? (fmap Right <$> b) <*? c bindOrdering :: Selective f => f Ordering -> (Ordering -> f a) -> f a bindOrdering x f = branch3 (toEither <$> x) (const <$> f LT) (const <$> f EQ) (const <$> f GT) where toEither LT = Left () toEither EQ = Right (Left ()) toEither GT = Right (Right ()) -------------------------------- Proof sketches -------------------------------- -- A convenient primitive which checks that the types of two given values -- coincide and returns the first value. (===) :: a -> a -> a x === y = if True then x else y infixl 0 === -- First, we typecheck the laws -- F1 (Free): f <$> select x y = select (fmap f <$> x) (fmap f <$> y) f1 :: Selective f => (b -> c) -> f (Either a b) -> f (a -> b) -> f c f1 f x y = f <$> select x y === select (fmap f <$> x) (fmap f <$> y) -- F2 (Free): select (first f <$> x) y = select x ((. f) <$> y) f2 :: Selective f => (a -> c) -> f (Either a b) -> f (c -> b) -> f b f2 f x y = select (first f <$> x) y === select x ((. f) <$> y) -- F3 (Free): select x (f <$> y) = select (first (flip f) <$> x) ((&) <$> y) f3 :: Selective f => (c -> a -> b) -> f (Either a b) -> f c -> f b f3 f x y = select x (f <$> y) === select (first (flip f) <$> x) ((&) <$> y) -- P1 (Generalised identity): select x (pure y) == either y id <$> x p1 :: Selective f => f (Either a b) -> (a -> b) -> f b p1 x y = select x (pure y) === either y id <$> x -- A more basic form of P1, from which P1 itself follows as a free theorem. -- Intuitively, both 'p1' and 'p1id' make the following Const instance illegal: -- -- @ -- instance Monoid m => Selective (Const m) where -- select (Const x) (Const _) = Const (x <> x) -- @ -- P1id (Identity): select x (pure id) == either id id <$> x p1id :: Selective f => f (Either a a) -> f a p1id x = select x (pure id) === either id id <$> x -- P2 (does not generally hold): select (pure (Left x)) y = ($x) <$> y p2 :: Selective f => a -> f (a -> b) -> f b p2 x y = select (pure (Left x)) y === y <*> pure x -- P3 (does not generally hold): select (pure (Right x)) y = pure x p3 :: Selective f => b -> f (a -> b) -> f b p3 x y = select (pure (Right x)) y === pure x -- A1 (Associativity): -- select x (select y z) = select (select (f <$> x) (g <$> y)) (h <$> z) -- where f x = Right <$> x -- g y = \a -> bimap (,a) ($a) y -- h z = uncurry z a1 :: Selective f => f (Either a b) -> f (Either c (a -> b)) -> f (c -> a -> b) -> f b a1 x y z = select x (select y z) === select (select (f <$> x) (g <$> y)) (h <$> z) where f x = Right <$> x g y = \a -> bimap (,a) ($a) y h z = uncurry z -- Intuitively, 'i1' makes the following Const instance illegal, by insisting -- that effects on the left hand side must be executed. -- -- @ -- instance Monoid m => Selective (Const m) where -- select _ _ = Const mempty -- @ -- -- If we decompose an effect @x :: f a@ into the effect itself @void x@ and the -- resulting pure value @a@, i.e. @void x *> pure a@, then it becomes clear that -- 'i1unit' means that all effects must be executed and the remainig pure value -- will be used to select whether to execute or skip the right hand side. -- i1unit (Interchange): (x *> y) <*? z = x *> (y <*? z) i1unit :: Selective f => f c -> f (Either a b) -> f (a -> b) -> f b i1unit x y z = (x *> y) <*? z === x *> (y <*? z) -- i1: x <*> (y <*? z) = (f <$> x <*> y) <*? (g <$> z) -- where -- f = (\ab -> bimap (, ab) ab) -- g = (\ca (c, ab) -> ab (ca c)) i1 :: Selective f => f (a -> b) -> f (Either c a) -> f (c -> a) -> f b i1 x y z = x <*> (y <*? z) === (f <$> x <*> y) <*? (g <$> z) where f ab = bimap (\c ca -> ab (ca c)) ab g ca = ($ca) -- D1 (distributivity): pure x <*? (y *> z) = (pure x <*? y) *> (pure x <*? z) d1 :: Selective f => Either a b -> f (a -> b) -> f (a -> b) -> f b d1 x y z = pure x <*? (y *> z) === (pure x <*? y) *> (pure x <*? z) -- TODO: Can we prove the following from D1? -- ifS (pure x) a1 b1 *> ifS (pure x) a2 b2 = ifS (pure x) (a1 *> a2) (b1 *> b2) -- Now let's typecheck some theorems -- This assumes P2, which does not always hold -- Identity: pure id <*> v = v t1 :: Selective f => f a -> f a t1 v = -- Express the lefthand side using 'apS' apS (pure id) v === -- Definition of 'apS' select (Left <$> pure id) ((&) <$> v) === -- Push 'Left' inside 'pure' select (pure (Left id)) ((&) <$> v) === -- Apply P2 ($id) <$> ((&) <$> v) === -- Simplify id <$> v === -- Functor identity: -- Functor identity: fmap id = id v -- Homomorphism: pure f <*> pure x = pure (f x) t2 :: Selective f => (a -> b) -> a -> f b t2 f x = -- Express the lefthand side using 'apS' apS (pure f) (pure x) === -- Definition of 'apS' select (Left <$> pure f) ((&) <$> pure x) === -- Push 'Left' inside 'pure' select (pure (Left f)) ((&) <$> pure x) === -- Applicative's fmap-pure law select (pure (Left f)) (pure ((&) x)) === -- Apply P1 either (((&) x)) id <$> pure (Left f) === -- Applicative's fmap-pure law pure (((&) x) f) === -- Simplify pure (f x) -- This assumes P2, which does not always hold -- Interchange: u <*> pure y = pure ($y) <*> u t3 :: Selective f => f (a -> b) -> a -> f b t3 u y = -- Express the lefthand side using 'apS' apS u (pure y) === -- Definition of 'apS' select (Left <$> u) ((&) <$> pure y) === -- Rewrite to have a pure second argument select (Left <$> u) (pure ($y)) === -- Apply P1 either ($y) id <$> (Left <$> u) === -- Simplify, obtaining (#) ($y) <$> u === -- Express right-hand side of the theorem using 'apS' apS (pure ($y)) u === -- Definition of 'apS' select (Left <$> pure ($y)) ((&) <$> u) === -- Push 'Left' inside 'pure' select (pure (Left ($y))) ((&) <$> u) === -- Apply P2 ($($y)) <$> ((&) <$> u) === -- Simplify, obtaining (#) ($y) <$> u -- Composition: (.) <$> u <*> v <*> w = u <*> (v <*> w) t4 :: Selective f => f (b -> c) -> f (a -> b) -> f a -> f c t4 u v w = -- Express the lefthand side using 'apS' apS (apS ((.) <$> u) v) w === -- Definition of 'apS' select (Left <$> select (Left <$> (.) <$> u) ((&) <$> v)) ((&) <$> w) === -- Apply F1 to push the leftmost 'Left' inside 'select' select (select (second Left <$> Left <$> (.) <$> u) ((Left .) <$> (&) <$> v)) ((&) <$> w) === -- Simplify select (select (Left <$> (.) <$> u) ((Left .) <$> (&) <$> v)) ((&) <$> w) === -- Pull (.) outside 'Left' select (select (first (.) <$> Left <$> u) ((Left .) <$> (&) <$> v)) ((&) <$> w) === -- Apply F2 to push @(.)@ to the function select (select (Left <$> u) ((. (.)) <$> (Left .) <$> (&) <$> v)) ((&) <$> w) === -- Simplify, obtaining (#) select (select (Left <$> u) ((Left .) <$> flip (.) <$> v)) ((&) <$> w) === -- Express the righthand side using 'apS' apS u (apS v w) === -- Definition of 'apS' select (Left <$> u) ((&) <$> select (Left <$> v) ((&) <$> w)) === -- Apply F1 to push @(&)@ inside 'select' select (Left <$> u) (select (Left <$> v) (((&) .) <$> (&) <$> w)) === -- Apply A1 to reassociate to the left select (select (Left <$> u) ((\y a -> bimap (,a) ($a) y) <$> Left <$> v)) (uncurry . ((&) .) <$> (&) <$> w) === -- Simplify select (select (Left <$> u) ((\y a -> Left (y, a)) <$> v)) ((\x (f, g) -> g (f x)) <$> w) === -- Apply F3 to pull the rightmost pure function inside 'select' select (first (flip ((\x (f, g) -> g (f x)))) <$> select (Left <$> u) ((\y a -> Left (y, a)) <$> v)) ((&) <$> w) === -- Simplify select (first (\(f, g) -> g . f) <$> select (Left <$> u) ((\y a -> Left (y, a)) <$> v)) ((&) <$> w) === -- Apply F1 to push the leftmost pure function inside 'select' select (select (Left <$> u) (((first (\(f, g) -> g . f)).) <$> (\y a -> Left (y, a)) <$> v)) ((&) <$> w) === -- Simplify, obtaining (#) select (select (Left <$> u) ((Left .) <$> flip (.) <$> v)) ((&) <$> w) --------------------------------- End of proofs -------------------------------- -- Various other sketches below -- Associate to the left -- f (a + b + c) -> f (a -> (b + c)) -> f (b -> c) -> f c l :: Selective f => f (Either a (Either b c)) -> f (a -> Either b c) -> f (b -> c) -> f c l x y z = x <*? y <*? z -- Associate to the right -- f (a + b) -> f (c + (a -> b)) -> f (c -> a -> b) -> f b r :: Selective f => f (Either a b) -> f (Either c (a -> b)) -> f (c -> a -> b) -> f b r x y z = x <*? (y <*? z) -- Normalise: go from right to left association normalise :: Selective f => f (Either a b) -> f (Either c (a -> b)) -> f (c -> a -> b) -> f b normalise x y z = (f <$> x) <*? (g <$> y) <*? (h <$> z) where f x = Right <$> x g y = \a -> bimap (,a) ($a) y h z = uncurry z -- Alternative normalisation which uses Scott encoding of pairs normalise2 :: Selective f => f (Either a b) -> f (Either c (a -> b)) -> f (c -> a -> b) -> f b normalise2 x y z = (f <$> x) <*? (g <$> y) <*? (h <$> z) where f x = Right <$> x g y = \a -> bimap (\c f -> f c a) ($a) y h z = ($z) -- h = (&) -- Alternative formulations of selective functors. -- Factoring out the selection logic into a pure argument class Applicative f => SelectiveBy f where selectBy :: (a -> Either (b -> c) c) -> f a -> f b -> f c fromSelectBy :: SelectiveBy f => f (Either a b) -> f (a -> b) -> f b fromSelectBy = selectBy (first ((&))) toSelectBy :: Selective f => (a -> Either (b -> c) c) -> f a -> f b -> f c toSelectBy f x y = select (f <$> x) ((&) <$> y) whenBy :: SelectiveBy f => f Bool -> f () -> f () whenBy = selectBy (bool (Right ()) (Left id)) -- A first-order version of selective functors. class Applicative f => SelectiveF f where selectF :: f (Either a b) -> f c -> f (Either a (b, c)) toF :: Selective f => f (Either a b) -> f c -> f (Either a (b, c)) toF x y = branch x (pure Left) ((\c b -> Right (b, c)) <$> y) fromF :: SelectiveF f => f (Either a b) -> f (a -> b) -> f b fromF x y = either id (uncurry ((&))) <$> selectF (swapEither <$> x) y -- A few variants that have a sum type in both arguments. They are not -- equivalent to 'Selective' of 'SelectiveF' unless we require that effects are -- executed from left to right. -- Composition of Applicative and Either monad class Applicative f => SelectiveA f where (|*|) :: f (Either e (a -> b)) -> f (Either e a) -> f (Either e b) -- Composition of Starry and Either monad -- See: https://duplode.github.io/posts/applicative-archery.html class Applicative f => SelectiveS f where (|.|) :: f (Either e (b -> c)) -> f (Either e (a -> b)) -> f (Either e (a -> c)) -- Composition of Monoidal and Either monad -- See: http://blog.ezyang.com/2012/08/applicative-functors/ class Applicative f => SelectiveM f where (|**|) :: f (Either e a) -> f (Either e b) -> f (Either e (a, b)) biselect :: Selective f => f (Either a b) -> f (Either a c) -> f (Either a (b, c)) biselect x y = select ((fmap Left . swapEither) <$> x) ((\e a -> fmap (a,) e) <$> y) (?*?) :: Selective f => f (Either a b) -> f (Either a c) -> f (Either a (b, c)) (?*?) = biselect a1M :: Selective f => f (Either a b) -> f (Either a c) -> f (Either a d) -> f (Either a (b, (c, d))) a1M x y z = x ?*? (y ?*? z) === fmap assoc <$> ((x ?*? y) ?*? z) where assoc ((a, b), c) = (a, (b, c)) apM :: SelectiveM f => f (a -> b) -> f a -> f b apM f x = fmap (either absurd (uncurry ($))) (fmap Right f |**| fmap Right x) fromM :: SelectiveM f => f (Either a b) -> f (a -> b) -> f b fromM x f = either id (\(a, f) -> f a) <$> (fmap swapEither x |**| fmap Right f) toM :: Selective f => f (Either e a) -> f (Either e b) -> f (Either e (a, b)) toM = biselect -- Proof that if select = selectM, and <*> = ap, then <*> = apS. apSEqualsApply :: (Selective f, Monad f) => f (a -> b) -> f a -> f b apSEqualsApply fab fa = fab <*> fa === -- Law: <*> = ap ap fab fa === -- Free theorem (?) selectM (Left <$> fab) ((&) <$> fa) === -- Law: selectM = select select (Left <$> fab) ((&) <$> fa) === -- Definition of apS apS fab fa -- | Selective function composition, where the first effect is always evaluated, -- but the second one can be skipped if the first value is @Nothing@. -- Thanks to the laws of 'Selective', this operator is associative, and has -- identity @pure (Just id)@. (.?) :: Selective f => f (Maybe (b -> c)) -> f (Maybe (a -> b)) -> f (Maybe (a -> c)) x .? y = select (maybe (Right Nothing) Left <$> x) ((\ab bc -> (bc .) <$> ab) <$> y) infixl 4 .? -- This assumes P2, which does not always hold -- Proof of left identity: pure (Just id) .? x = x t5 :: Selective f => f (Maybe (a -> b)) -> f (Maybe (a -> b)) t5 x = --- Lefthand side pure (Just id) .? x === -- Express the lefthand side by expanding the definition of '.?' select (maybe (Right Nothing) Left <$> pure (Just id)) ((\ab bc -> (bc .) <$> ab) <$> x) === -- Simplify select (pure $ Left id) ((\ab bc -> (bc .) <$> ab) <$> x) === -- Apply P2 ($id) <$> ((\ab bc -> (bc .) <$> ab) <$> x) === -- Simplify (($id) <$> (\ab bc -> (bc .) <$> ab) <$> x) === -- Functor identity: fmap id = id id <$> x === x -- Proof of right identity: x .? pure (Just id) = x t6 :: Selective f => f (Maybe (a -> b)) -> f (Maybe (a -> b)) t6 x = --- Lefthand side x .? pure (Just id) === -- Express the lefthand side by expanding the definition of '.?' select (maybe (Right Nothing) Left <$> x) ((\ab bc -> (bc .) <$> ab) <$> pure (Just id)) === -- Simplify select (maybe (Right Nothing) Left <$> x) (pure Just) === -- Apply P1 either Just id <$> (maybe (Right Nothing) Left <$> x) === -- Functor identity: fmap id = id id <$> x === x -- Proof of associativity: (x .? y) .? z = x .? (y .? z) t7 :: Selective f => f (Maybe (c -> d)) -> f (Maybe (b -> c)) -> f (Maybe (a -> b)) -> f (Maybe (a -> d)) t7 x y z = -- Lefthand side (x .? y) .? z === -- Express the lefthand side by expanding the definition of '.?' select (maybe (Right Nothing) Left <$> (select (maybe (Right Nothing) Left <$> x) ((\ab bc -> (bc .) <$> ab) <$> y))) ((\ab bc -> (bc .) <$> ab) <$> z) === -- Apply F3 to move the rightmost pure function into the outer 'select' select (first (flip $ (\ab bc -> (bc .) <$> ab)) <$> maybe (Right Nothing) Left <$> (select (maybe (Right Nothing) Left <$> x) ((\ab bc -> (bc .) <$> ab) <$> y))) ((&) <$> z) === -- Simplify select (maybe (Right Nothing) (\bc -> Left $ fmap $ (bc .)) <$> (select (maybe (Right Nothing) Left <$> x) ((\ab bc -> (bc .) <$> ab) <$> y))) ((&) <$> z) === -- Apply F1 to move the pure function into the inner 'select' select (select (second (maybe (Right Nothing) (\bc -> Left $ fmap $ (bc .))) <$> maybe (Right Nothing) Left <$> x) (((maybe (Right Nothing) (\bc -> Left $ fmap $ (bc .))).) <$> (\ab bc -> (bc .) <$> ab) <$> y)) ((&) <$> z) === -- Simplify, obtaining (#) select (select (maybe (Right (Right Nothing)) Left <$> x) ((\mbc cd -> maybe (Right Nothing) (\bc -> Left $ fmap ((cd . bc) .)) mbc) <$> y)) ((&) <$> z) === -- Righthand side x .? (y .? z) === -- Express the righthand side by expanding the definition of '.?' select (maybe (Right Nothing) Left <$> x) ((\ab bc -> (bc .) <$> ab) <$> (select (maybe (Right Nothing) Left <$> y) ((\ab bc -> (bc .) <$> ab) <$> z))) === -- Apply F1 to move the pure function into the inner 'select' select (maybe (Right Nothing) Left <$> x) (select (second ((\ab bc -> (bc .) <$> ab)) <$> maybe (Right Nothing) Left <$> y) ((((\ab bc -> (bc .) <$> ab)).) <$> (\ab bc -> (bc .) <$> ab) <$> z)) === -- Apply A1 to reassociate to the left select (select (fmap Right <$> maybe (Right Nothing) Left <$> x) ((\y a -> bimap (,a) ($a) y) <$> second ((\ab bc -> (bc .) <$> ab)) <$> maybe (Right Nothing) Left <$> y)) (uncurry <$> (((\ab bc -> (bc .) <$> ab)).) <$> (\ab bc -> (bc .) <$> ab) <$> z) === -- Simplify select (select (maybe (Right (Right Nothing)) Left <$> x) ((\m a -> maybe (Right Nothing) (Left . (,a)) m) <$> y)) ((\ab (bc, cd) -> ((cd . bc) .) <$> ab) <$> z) === -- Apply F3 to move the rightmost pure function into the outer 'select' select (first (flip $ \ab (bc, cd) -> ((cd . bc) .) <$> ab) <$> select (maybe (Right (Right Nothing)) Left <$> x) ((\m a -> maybe (Right Nothing) (Left . (,a)) m) <$> y)) ((&) <$> z) === -- Apply F1 to move the pure function into the inner 'select', obtaining (#) select (select (maybe (Right (Right Nothing)) Left <$> x) ((\mbc cd -> maybe (Right Nothing) (\bc -> Left $ fmap ((cd . bc) .)) mbc) <$> y)) ((&) <$> z) ------------------------ McCarthy's Conditional combinator ------------------------- -- See: http://www4.di.uminho.pt/~jno/ps/pdbc.pdf -- And also: https://themattchan.com/docs/algprog.pdf -- Guard function used in McCarthy's conditional -- | It provides information about the outcome of testing @p@ on some input @a@, -- encoded in terms of the coproduct injections without losing the input -- @a@ itself. grdS :: Applicative f => f (a -> Bool) -> f a -> f (Either a a) grdS f a = selector <$> applyF f (dup <$> a) where dup x = (x, x) applyF fab faa = bimap <$> fab <*> pure id <*> faa selector (b, x) = bool (Right x) (Left x) b -- | McCarthy's conditional, denoted p -> f,g is a well-known functional -- combinator, which suggests that, to reason about conditionals, one may -- seek help in the algebra of coproducts. -- -- This combinator is very similar to the very nature of the 'select' -- operator and benefits from a series of properties and laws. condS :: Selective f => f (b -> Bool) -> f (b -> c) -> f (b -> c) -> f b -> f c condS p f g = (\r -> branch r f g) . grdS p ------------------------ Carter Schonwald's copatterns ------------------------- -- See: https://github.com/cartazio/symmetric-monoidal/blob/15b209953b7d4a47651f615b02dbb0171de8af40/src/Control/Monoidal.hs#L93 -- And also: https://twitter.com/andreymokhov/status/1102648479841701888 data Choose a b c where CLeft :: Choose a b a CRight :: Choose a b b newtype Choice a b = Choice (forall r . Choose a b r -> r) class SelectiveC f where choose :: f (Either a b) -> Choice (f (a -> c)) (f (b -> c)) -> f c -- Recover selective 'branch' from 'choose'. branchC :: SelectiveC f => f (Either a b) -> f (a -> c) -> f (b -> c) -> f c branchC x l r = choose x $ Choice $ \c -> case c of { CLeft -> l; CRight -> r } -- Recover 'choose' from selective 'branch'. chooseS :: Selective f => f (Either a b) -> Choice (f (a -> c)) (f (b -> c)) -> f c chooseS x (Choice c) = branch x (c CLeft) (c CRight) ------------------------------- ApplicativeError ------------------------------- -- See https://twitter.com/LukaJacobowitz/status/1148756733243940864. class Applicative f => ApplicativeEither f e where raise :: e -> f a handle :: f a -> f (e -> a) -> f a -- Note that the handler may fail too -- If the first computation succeeds with an @a@, this function just returns it. -- Otherwise, it attempts to handle the error @e@ by running the second -- computation. If the latter fails too, we return the very first error @e@, -- otherwise we handle the error with the obtained function @e -> a@ and return -- the resulting value @a@. handleS :: Selective f => f (Either e a) -> f (Either e (e -> a)) -> f (Either e a) handleS x y = select (second Right <$> x) (handlePure <$> y) where handlePure :: Either e (e -> a) -> e -> Either e a handlePure (Left _) e = Left e handlePure (Right f) e = Right (f e) instance Selective f => ApplicativeEither (ComposeEither f e) e where raise = ComposeEither . pure . Left handle (ComposeEither x) (ComposeEither y) = ComposeEither (handleS x y) ------------------------------- Free ArrowChoice ------------------------------- -- A free 'ArrowChoice' built on top of base components @f i o@. newtype FreeArrowChoice f a b = FreeArrowChoice { runFreeArrowChoice :: forall arr. ArrowChoice arr => (forall i o. f i o -> arr i o) -> arr a b } instance Category (FreeArrowChoice f) where id = FreeArrowChoice (\_ -> C.id) FreeArrowChoice x . FreeArrowChoice y = FreeArrowChoice (\t -> x t C.. y t) instance Arrow (FreeArrowChoice f) where arr x = FreeArrowChoice (\_ -> A.arr x) first (FreeArrowChoice x) = FreeArrowChoice (\t -> A.first (x t)) instance ArrowChoice (FreeArrowChoice f) where left (FreeArrowChoice x) = FreeArrowChoice (\t -> A.left (x t)) -- A constant arrow, similar to the 'Const' applicative functor. newtype ConstArrow m a b = ConstArrow { getConstArrow :: m } instance Monoid m => Category (ConstArrow m) where id = ConstArrow mempty ConstArrow x . ConstArrow y = ConstArrow (mappend x y) instance Monoid m => Arrow (ConstArrow m) where arr _ = ConstArrow mempty first (ConstArrow x) = ConstArrow x instance Monoid m => ArrowChoice (ConstArrow m) where left (ConstArrow x) = ConstArrow x -- Collect all base arrows in a 'FreeArrowChoice'. foldArrowChoice :: Monoid m => (forall i o. f i o -> m) -> FreeArrowChoice f a b -> m foldArrowChoice f arr = getConstArrow $ runFreeArrowChoice arr (ConstArrow . f) -- Execute a 'FreeArrowChoice' in an arbitrary monad. runArrowChoice :: Monad m => (forall i o. f i o -> (i -> m o)) -> FreeArrowChoice f a b -> (a -> m b) runArrowChoice f arr = runKleisli $ runFreeArrowChoice arr (Kleisli . f) -------------------------------- Simplified Haxl ------------------------------- data BlockedRequests instance Semigroup BlockedRequests where (<>) x _ = case x of {} -- A Haxl computation is either completed (Done) or Blocked on pending data requests data Result a = Done a | Blocked BlockedRequests (Haxl a) deriving Functor newtype Haxl a = Haxl { runHaxl :: IO (Result a) } deriving Functor instance Applicative Haxl where pure = Haxl . return . Done Haxl iof <*> Haxl iox = Haxl $ do rf <- iof rx <- iox return $ case (rf, rx) of (Done f , _ ) -> f <$> rx (_ , Done x ) -> ($x) <$> rf (Blocked bf f, Blocked bx x) -> Blocked (bf <> bx) (f <*> x) -- parallelism instance Selective Haxl where select (Haxl iox) (Haxl iof) = Haxl $ do rx <- iox rf <- iof return $ case (rx, rf) of (Done (Right b), _ ) -> Done b -- abandon the second computation (Done (Left a), _ ) -> ($a) <$> rf (_ , Done f) -> either f id <$> rx (Blocked bx x , Blocked bf f) -> Blocked (bx <> bf) (select x f) -- speculative -- execution instance Monad Haxl where return = pure Haxl iox >>= f = Haxl $ do rx <- iox case rx of Done x -> runHaxl (f x) -- dynamic dependency on runtime value 'x' Blocked bx x -> return (Blocked bx (x >>= f)) selective-0.7/examples/Teletype.hs0000644000000000000000000000440714374406574015521 0ustar0000000000000000{-# LANGUAGE DeriveFunctor, FlexibleInstances, GADTs #-} module Teletype where import Prelude hiding (getLine, putStrLn) import qualified Prelude as IO import qualified Control.Monad as IO import Control.Selective import Control.Selective.Free -- See Section 5.2 of the paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf -- | The classic @Teletype@ base functor. data TeletypeF a = Read (String -> a) | Write String a deriving Functor instance Eq (TeletypeF ()) where Read _ == Read _ = True Write x () == Write y () = x == y _ == _ = False instance Show (TeletypeF a) where show (Read _) = "Read" show (Write s _) = "Write " ++ show s -- | Interpret 'TeletypeF' commands as 'IO' actions. toIO :: TeletypeF a -> IO a toIO (Read f) = f <$> IO.getLine toIO (Write s a) = a <$ IO.putStrLn s -- | A Teletype program is a free selective functor on top of the base functor -- 'TeletypeF'. type Teletype a = Select TeletypeF a -- | A convenient alias for reading a string. getLine :: Teletype String getLine = liftSelect (Read id) -- | A convenient alias for writing a string. putStrLn :: String -> Teletype () putStrLn s = liftSelect (Write s ()) -- | The ping-pong example from the introduction section of the paper -- implemented using free selective functors. -- -- It can be statically analysed for effects: -- -- @ -- > getEffects pingPongS -- [Read,Write "pong"] -- @ -- -- @ -- > getNecessaryEffects pingPongS -- [Read] -- @ -- -- If can also be executed in IO: -- -- @ -- > runSelect toIO pingPongS -- hello -- > runSelect toIO pingPongS -- ping -- pong -- @ pingPongS :: Teletype () pingPongS = whenS (fmap ("ping"==) getLine) (putStrLn "pong") ------------------------------- Ping-pong example ------------------------------ -- | Monadic ping-pong, which has the desired behaviour, but cannot be -- statically analysed. pingPongM :: IO () pingPongM = IO.getLine >>= \s -> IO.when (s == "ping") (IO.putStrLn "pong") -- | Applicative ping-pong, which always executes both effect, but can be -- statically analysed. pingPongA :: IO () pingPongA = IO.getLine *> IO.putStrLn "pong" -- | A monadic greeting. Cannot be implemented using selective functors. greeting :: IO () greeting = IO.getLine >>= \name -> IO.putStrLn ("Hello, " ++ name) selective-0.7/examples/Teletype/Rigid.hs0000644000000000000000000000425014374406574016553 0ustar0000000000000000{-# LANGUAGE DeriveFunctor, FlexibleInstances, GADTs #-} module Teletype.Rigid where import Prelude hiding (getLine, putStrLn) import qualified Prelude as IO import qualified Control.Monad as IO import Control.Selective import Control.Selective.Rigid.Free -- See Section 5.2 of the paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf -- | The classic @Teletype@ base functor. data TeletypeF a = Read (String -> a) | Write String a deriving Functor instance Eq (TeletypeF ()) where Read _ == Read _ = True Write x () == Write y () = x == y _ == _ = False instance Show (TeletypeF a) where show (Read _) = "Read" show (Write s _) = "Write " ++ show s -- | Interpret 'TeletypeF' commands as 'IO' actions. toIO :: TeletypeF a -> IO a toIO (Read f) = f <$> IO.getLine toIO (Write s a) = a <$ IO.putStrLn s -- | A Teletype program is a free selective functor on top of the base functor -- 'TeletypeF'. type Teletype a = Select TeletypeF a -- | A convenient alias for reading a string. getLine :: Teletype String getLine = liftSelect (Read id) -- | A convenient alias for writing a string. putStrLn :: String -> Teletype () putStrLn s = liftSelect (Write s ()) -- | The ping-pong example from the introduction section of the paper -- implemented using free selective functors. -- -- @ -- > getEffects pingPongS -- [Read,Write "pong"] -- @ -- -- If can also be executed in IO: -- -- @ -- > runSelect toIO pingPongS -- hello -- > runSelect toIO pingPongS -- ping -- pong -- @ pingPongS :: Teletype () pingPongS = whenS (fmap ("ping"==) getLine) (putStrLn "pong") ------------------------------- Ping-pong example ------------------------------ -- | Monadic ping-pong, which has the desired behaviour, but cannot be -- statically analysed. pingPongM :: IO () pingPongM = IO.getLine >>= \s -> IO.when (s == "ping") (IO.putStrLn "pong") -- | Applicative ping-pong, which always executes both effect, but can be -- statically analysed. pingPongA :: IO () pingPongA = IO.getLine *> IO.putStrLn "pong" -- | A monadic greeting. Cannot be implemented using selective functors. greeting :: IO () greeting = IO.getLine >>= \name -> IO.putStrLn ("Hello, " ++ name) selective-0.7/test/Test.hs0000644000000000000000000000271214374406574014003 0ustar0000000000000000-- A little testing framework module Test where import Data.List (intercalate) import System.Exit (exitFailure) import Test.QuickCheck hiding (Success, Failure, expectFailure) data Expect = ExpectSuccess | ExpectFailure deriving Eq data Test = Test String Expect Property data Tests = Leaf Test | Node String [Tests] testGroup :: String -> [Tests] -> Tests testGroup = Node expectSuccess :: Testable a => String -> a -> Tests expectSuccess name p = Leaf $ Test name ExpectSuccess (property p) expectFailure :: Testable a => String -> a -> Tests expectFailure name p = Leaf $ Test name ExpectFailure (property p) runTest :: [String] -> Test -> IO () runTest labels (Test name expect property) = do let label = "[" ++ intercalate "." (reverse labels) ++ "] " ++ name result <- quickCheckWithResult (stdArgs { chatty = False }) property case (expect, isSuccess result) of (ExpectSuccess, True) -> putStrLn $ "[OK] " ++ label (ExpectFailure, False) -> putStrLn $ "[OK, expected failure] " ++ label (ExpectFailure, True) -> putStrLn $ "[Warning, unexpected success] " ++ label (ExpectSuccess, False) -> do putStrLn $ "\n[Failure] " ++ label ++ "\n" putStrLn $ output result exitFailure runTests :: Tests -> IO () runTests = go [] where go labels (Leaf test) = runTest labels test go labels (Node label tests) = mapM_ (go (label : labels)) tests selective-0.7/examples/Validation.hs0000644000000000000000000000261714374406574016021 0ustar0000000000000000{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes #-} module Validation where import Control.Selective -- See Section 2.2 of the paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf type Radius = Word type Width = Word type Height = Word -- | A circle or rectangle. data Shape = Circle Radius | Rectangle Width Height deriving (Eq, Show) -- Some validation examples: -- -- > shape (Success True) (Success 1) (Failure ["width?"]) (Failure ["height?"]) -- > Success (Circle 1) -- -- > shape (Success False) (Failure ["radius?"]) (Success 2) (Success 3) -- > Success (Rectangle 2 3) -- -- > shape (Success False) (Failure ["radius?"]) (Success 2) (Failure ["height?"]) -- > Failure ["height?"] -- -- > shape (Success False) (Success 1) (Failure ["width?"]) (Failure ["height?"]) -- > Failure ["width?", "height?"] -- -- > shape (Failure ["choice?"]) (Failure ["radius?"]) (Success 2) (Failure ["height?"]) -- > Failure ["choice?"] shape :: Selective f => f Bool -> f Radius -> f Width -> f Height -> f Shape shape s r w h = ifS s (Circle <$> r) (Rectangle <$> w <*> h) -- > s1 = shape (Failure ["choice 1?"]) (Success 1) (Failure ["width 1?"]) (Success 3) -- > s2 = shape (Success False) (Success 1) (Success 2) (Failure ["height 2?"]) -- > twoShapes s1 s2 -- > Failure ["choice 1?","height 2?"] twoShapes :: Selective f => f Shape -> f Shape -> f (Shape, Shape) twoShapes s1 s2 = (,) <$> s1 <*> s2 selective-0.7/CHANGES.md0000644000000000000000000000251114400776750013134 0ustar0000000000000000# Change log ## 0.7 * Drop `MonadTrans (ExceptT e)` instance to allow `transformers-0.6.1`. See #70. ## 0.6 * Start supporting GHC 9.4. See #66. * Add `ComposeTraversable`. See #65. * Make the `Applicative` instance of `ComposeEither` more interesting by relying on the `Selective f` constraint. See #64. * Make the `Lift` instance lazier. See #63. * Stop supporting GHC <= 8.6. See #62. * Add `Control.Selective.Trans.Except` transformer. See #39. ## 0.5 * Allow `transformers-0.6`, see #47. * Drop dependencies on `mtl` and `tasty`. See #45, #46. * Derive the stock `Eq` and `Ord` instances for `Validation`, see #43. * Add `selectT`, see #42. * Add more general instances for `IdentityT` and `ReaderT`. This is technically a breaking change because `Selective` is not a superclass of `Monad`. See #38. ## 0.4.1 * Allow newer QuickCheck. ## 0.4 * Add multi-way selective functors: `Control.Selective.Multi`. ## 0.3 * Add freer rigid selective functors: `Control.Selective.Rigid.Freer`. * Rename `Control.Selective.Free.Rigid` to `Control.Selective.Rigid.Free`. * Add free selective functors: `Control.Selective.Free`. * Switch to more conventional field names in `SelectA` and `SelectM`. ## 0.2 * Make compatible with GHC >= 8.0.2. * Add another free construction `Control.Selective.Free`. * Add several new `Selective` instances. selective-0.7/README.md0000644000000000000000000002426214374406574013034 0ustar0000000000000000# Selective applicative functors [![Hackage version](https://img.shields.io/hackage/v/selective.svg?label=Hackage)](https://hackage.haskell.org/package/selective) [![Build status](https://img.shields.io/github/workflow/status/snowleopard/selective/ci/master.svg)](https://github.com/snowleopard/selective/actions) This is a library for *selective applicative functors*, or just *selective functors* for short, an abstraction between applicative functors and monads, introduced in [this paper](https://dl.acm.org/ft_gateway.cfm?id=3341694). ## What are selective functors? While you're encouraged to read the paper, here is a brief description of the main idea. Consider the following new type class introduced between `Applicative` and `Monad`: ```haskell class Applicative f => Selective f where select :: f (Either a b) -> f (a -> b) -> f b -- | An operator alias for 'select'. (<*?) :: Selective f => f (Either a b) -> f (a -> b) -> f b (<*?) = select infixl 4 <*? ``` Think of `select` as a *selective function application*: you **must apply** the function of type `a -> b` when given a value of type `Left a`, but you **may skip** the function and associated effects, and simply return `b` when given `Right b`. Note that you can write a function with this type signature using `Applicative` functors, but it will always execute the effects associated with the second argument, hence being potentially less efficient: ```haskell selectA :: Applicative f => f (Either a b) -> f (a -> b) -> f b selectA x f = (\e f -> either f id e) <$> x <*> f ``` Any `Applicative` instance can thus be given a corresponding `Selective` instance simply by defining `select = selectA`. The opposite is also true in the sense that one can recover the operator `<*>` from `select` as follows (I'll use the suffix `S` to denote `Selective` equivalents of commonly known functions). ```haskell apS :: Selective f => f (a -> b) -> f a -> f b apS f x = select (Left <$> f) ((&) <$> x) ``` Here we wrap a given function `a -> b` into `Left` and turn the value `a` into a function `($a)`, which simply feeds itself to the function `a -> b` yielding `b` as desired. Note: `apS` is a perfectly legal application operator `<*>`, i.e. it satisfies the laws dictated by the `Applicative` type class as long as [the laws](#laws) of the `Selective` type class hold. The `branch` function is a natural generalisation of `select`: instead of skipping an unnecessary effect, it chooses which of the two given effectful functions to apply to a given argument; the other effect is unnecessary. It is possible to implement `branch` in terms of `select`, which is a good puzzle (give it a try!). ```haskell branch :: Selective f => f (Either a b) -> f (a -> c) -> f (b -> c) -> f c branch = ... -- Try to figure out the implementation! ``` Finally, any `Monad` is `Selective`: ```haskell selectM :: Monad f => f (Either a b) -> f (a -> b) -> f b selectM mx mf = do x <- mx case x of Left a -> fmap ($a) mf Right b -> pure b ``` Selective functors are sufficient for implementing many conditional constructs, which traditionally require the (more powerful) `Monad` type class. For example: ```haskell -- | Branch on a Boolean value, skipping unnecessary effects. ifS :: Selective f => f Bool -> f a -> f a -> f a ifS i t e = branch (bool (Right ()) (Left ()) <$> i) (const <$> t) (const <$> e) -- | Conditionally perform an effect. whenS :: Selective f => f Bool -> f () -> f () whenS x act = ifS x act (pure ()) -- | Keep checking an effectful condition while it holds. whileS :: Selective f => f Bool -> f () whileS act = whenS act (whileS act) -- | A lifted version of lazy Boolean OR. (<||>) :: Selective f => f Bool -> f Bool -> f Bool (<||>) a b = ifS a (pure True) b -- | A lifted version of 'any'. Retains the short-circuiting behaviour. anyS :: Selective f => (a -> f Bool) -> [a] -> f Bool anyS p = foldr ((<||>) . p) (pure False) -- | Return the first @Right@ value. If both are @Left@'s, accumulate errors. orElse :: (Selective f, Semigroup e) => f (Either e a) -> f (Either e a) -> f (Either e a) orElse x = select (Right <$> x) . fmap (\y e -> first (e <>) y) ``` See more examples in [src/Control/Selective.hs](src/Control/Selective.hs). Code written using selective combinators can be both statically analysed (by reporting all possible effects of a computation) and efficiently executed (by skipping unnecessary effects). ## Laws Instances of the `Selective` type class must satisfy a few laws to make it possible to refactor selective computations. These laws also allow us to establish a formal relation with the `Applicative` and `Monad` type classes. * Identity: ```haskell x <*? pure id = either id id <$> x ``` * Distributivity (note that `y` and `z` have the same type `f (a -> b)`): ```haskell pure x <*? (y *> z) = (pure x <*? y) *> (pure x <*? z) ``` * Associativity: ```haskell x <*? (y <*? z) = (f <$> x) <*? (g <$> y) <*? (h <$> z) where f x = Right <$> x g y = \a -> bimap (,a) ($a) y h z = uncurry z ``` * Monadic select (for selective functors that are also monads): ```haskell select = selectM ``` There are also a few useful theorems: * Apply a pure function to the result: ```haskell f <$> select x y = select (fmap f <$> x) (fmap f <$> y) ``` * Apply a pure function to the `Left` case of the first argument: ```haskell select (first f <$> x) y = select x ((. f) <$> y) ``` * Apply a pure function to the second argument: ```haskell select x (f <$> y) = select (first (flip f) <$> x) ((&) <$> y) ``` * Generalised identity: ```haskell x <*? pure y = either y id <$> x ``` * A selective functor is *rigid* if it satisfies `<*> = apS`. The following *interchange* law holds for rigid selective functors: ```haskell x *> (y <*? z) = (x *> y) <*? z ``` Note that there are no laws for selective application of a function to a pure `Left` or `Right` value, i.e. we do not require that the following laws hold: ```haskell select (pure (Left x)) y = ($x) <$> y -- Pure-Left select (pure (Right x)) y = pure x -- Pure-Right ``` In particular, the following is allowed too: ```haskell select (pure (Left x)) y = pure () -- when y :: f (a -> ()) select (pure (Right x)) y = const x <$> y ``` We therefore allow `select` to be selective about effects in these cases, which in practice allows to under- or over-approximate possible effects in static analysis using instances like `Under` and `Over`. If `f` is also a `Monad`, we require that `select = selectM`, from which one can prove `apS = <*>`, and furthermore the above `Pure-Left` and `Pure-Right` properties now hold. ## Static analysis of selective functors Like applicative functors, selective functors can be analysed statically. We can make the `Const` functor an instance of `Selective` as follows. ```haskell instance Monoid m => Selective (Const m) where select = selectA ``` Although we don't need the function `Const m (a -> b)` (note that `Const m (Either a b)` holds no values of type `a`), we choose to accumulate the effects associated with it. This allows us to extract the static structure of any selective computation very similarly to how this is done with applicative computations. The `Validation` instance is perhaps a bit more interesting. ```haskell data Validation e a = Failure e | Success a deriving (Functor, Show) instance Semigroup e => Applicative (Validation e) where pure = Success Failure e1 <*> Failure e2 = Failure (e1 <> e2) Failure e1 <*> Success _ = Failure e1 Success _ <*> Failure e2 = Failure e2 Success f <*> Success a = Success (f a) instance Semigroup e => Selective (Validation e) where select (Success (Right b)) _ = Success b select (Success (Left a)) f = Success ($a) <*> f select (Failure e ) _ = Failure e ``` Here, the last line is particularly interesting: unlike the `Const` instance, we choose to actually skip the function effect in case of `Failure`. This allows us not to report any validation errors which are hidden behind a failed conditional. Let's clarify this with an example. Here we define a function to construct a `Shape` (a circle or a rectangle) given a choice of the shape `s` and the shape's parameters (`r`, `w`, `h`) in a selective context `f`. ```haskell type Radius = Int type Width = Int type Height = Int data Shape = Circle Radius | Rectangle Width Height deriving Show shape :: Selective f => f Bool -> f Radius -> f Width -> f Height -> f Shape shape s r w h = ifS s (Circle <$> r) (Rectangle <$> w <*> h) ``` We choose `f = Validation [String]` to report the errors that occurred when parsing a value. Let's see how it works. ```haskell > shape (Success True) (Success 10) (Failure ["no width"]) (Failure ["no height"]) Success (Circle 10) > shape (Success False) (Failure ["no radius"]) (Success 20) (Success 30) Success (Rectangle 20 30) > shape (Success False) (Failure ["no radius"]) (Success 20) (Failure ["no height"]) Failure ["no height"] > shape (Success False) (Failure ["no radius"]) (Failure ["no width"]) (Failure ["no height"]) Failure ["no width","no height"] > shape (Failure ["no choice"]) (Failure ["no radius"]) (Success 20) (Failure ["no height"]) Failure ["no choice"] ``` In the last example, since we failed to parse which shape has been chosen, we do not report any subsequent errors. But it doesn't mean we are short-circuiting the validation. We will continue accumulating errors as soon as we get out of the opaque conditional, as demonstrated below. ```haskell twoShapes :: Selective f => f Shape -> f Shape -> f (Shape, Shape) twoShapes s1 s2 = (,) <$> s1 <*> s2 > s1 = shape (Failure ["no choice 1"]) (Failure ["no radius 1"]) (Success 20) (Failure ["no height 1"]) > s2 = shape (Success False) (Failure ["no radius 2"]) (Success 20) (Failure ["no height 2"]) > twoShapes s1 s2 Failure ["no choice 1","no height 2"] ``` ## Do we still need monads? Yes! Here is what selective functors cannot do: `join :: Selective f => f (f a) -> f a`. ## Further reading * A paper introducing selective functors: https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf. * An older blog post introducing selective functors: https://blogs.ncl.ac.uk/andreymokhov/selective. selective-0.7/LICENSE0000644000000000000000000000206314374406574012555 0ustar0000000000000000MIT License Copyright (c) 2018-2023 Andrey Mokhov Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. selective-0.7/selective.cabal0000644000000000000000000000671014400776765014524 0ustar0000000000000000name: selective version: 0.7 synopsis: Selective applicative functors license: MIT license-file: LICENSE author: Andrey Mokhov , github: @snowleopard maintainer: Andrey Mokhov , github: @snowleopard copyright: Andrey Mokhov, 2018-2023 homepage: https://github.com/snowleopard/selective bug-reports: https://github.com/snowleopard/selective/issues category: Control build-type: Simple cabal-version: 1.18 tested-with: GHC==9.4.4, GHC==9.2.6, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5 description: Selective applicative functors: declare your effects statically, select which to execute dynamically. . This is a library for /selective applicative functors/, or just /selective functors/ for short, an abstraction between applicative functors and monads, introduced in . extra-doc-files: CHANGES.md README.md source-repository head type: git location: https://github.com/snowleopard/selective.git library hs-source-dirs: src exposed-modules: Control.Selective, Control.Selective.Free, Control.Selective.Multi, Control.Selective.Rigid.Free, Control.Selective.Rigid.Freer, Control.Selective.Trans.Except build-depends: base >= 4.9 && < 5, containers >= 0.5.5.1 && < 0.7, transformers >= 0.4.2.0 && < 0.7 default-language: Haskell2010 other-extensions: DeriveFunctor, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, TupleSections ghc-options: -Wall -fno-warn-name-shadowing -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints if impl(ghc >= 9.2) ghc-options: -Wno-operator-whitespace-ext-conflict test-suite main hs-source-dirs: test, examples other-modules: Build, Laws, Parser, Processor, Query, Sketch, Teletype, Teletype.Rigid, Test, Validation type: exitcode-stdio-1.0 main-is: Main.hs build-depends: base >= 4.7 && < 5, containers >= 0.5.5.1 && < 0.7, QuickCheck >= 2.8 && < 2.15, selective, transformers >= 0.4.2.0 && < 0.7 default-language: Haskell2010 ghc-options: -Wall -fno-warn-name-shadowing -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints if impl(ghc >= 9.2) ghc-options: -Wno-operator-whitespace-ext-conflict