lens-action-0.2.2/0000755000000000000000000000000013137001530012106 5ustar0000000000000000lens-action-0.2.2/.ghci0000644000000000000000000000012513137001530013017 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h lens-action-0.2.2/CHANGELOG.markdown0000644000000000000000000000103713137001530015142 0ustar00000000000000000.2.2 ----- * Add a library dependency for the `doctests` test suite 0.2.1 ----- * Revamp `Setup.hs` to use `cabal-doctest`. This makes it build with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and sandboxes. 0.2.0.2 --- * Migrate to new `phantom` definition in `contravariant` 0.2.0.1 --- * Add `Control.Lens.Action.Type` to exposed-modules list. 0.2 --- * `profunctors-5` and `lens-4.10` support 0.1.0.1 --- * Add `Control.Lens.Action.Type` to exposed-modules list. 0.1 ---- * Initial split from lens package lens-action-0.2.2/README.markdown0000644000000000000000000000112513137001530014606 0ustar0000000000000000lens-action =========== [![Hackage](https://img.shields.io/hackage/v/lens-action.svg)](https://hackage.haskell.org/package/lens-action) [![Build Status](https://secure.travis-ci.org/ekmett/lens-action.png?branch=master)](http://travis-ci.org/ekmett/lens-action) This package contains combinators and types for working with monadic getters and folds as split off from the original `lens` package. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett lens-action-0.2.2/lens-action.cabal0000644000000000000000000000436713137001530015320 0ustar0000000000000000name: lens-action category: Data, Lenses, Generics version: 0.2.2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/lens-action/ bug-reports: http://github.com/ekmett/lens-action/issues copyright: Copyright (C) 2012-2014 Edward A. Kmett build-type: Custom -- build-tools: cpphs tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 synopsis: Monadic Getters and Folds description: This package contains combinators and types for working with monadic getters and folds as split off from the original lens package. extra-source-files: .ghci .gitignore CHANGELOG.markdown README.markdown Warning.hs custom-setup setup-depends: base >= 4.3 && <5, Cabal >= 1.10, cabal-doctest >= 1 && <1.1 source-repository head type: git location: git://github.com/ekmett/lens-action.git -- You can disable the doctests test suite with -f-test-doctests flag test-doctests default: True manual: True library build-depends: lens >= 4.7 && < 5, base >= 4.5 && < 5, comonad >= 4 && < 6, contravariant >= 1.2.1 && < 2, profunctors >= 4 && < 6, mtl >= 2.0.1 && < 2.3, semigroups >= 0.8.4 && < 1, semigroupoids >= 4 && < 6, transformers >= 0.2 && < 0.6 exposed-modules: Control.Lens.Action Control.Lens.Action.Internal Control.Lens.Action.Reified Control.Lens.Action.Type cpp-options: -traditional ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields -fmax-simplifier-iterations=10 hs-source-dirs: src -- Verify the results of the examples test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs ghc-options: -Wall -threaded hs-source-dirs: tests if !flag(test-doctests) buildable: False else build-depends: base, doctest >= 0.9.1, filepath, directory, lens-action lens-action-0.2.2/Setup.lhs0000644000000000000000000000124113137001530013714 0ustar0000000000000000\begin{code} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} module Main (main) where #ifndef MIN_VERSION_cabal_doctest #define MIN_VERSION_cabal_doctest(x,y,z) 0 #endif #if MIN_VERSION_cabal_doctest(1,0,0) import Distribution.Extra.Doctest ( defaultMainWithDoctests ) main :: IO () main = defaultMainWithDoctests "doctests" #else #ifdef MIN_VERSION_Cabal -- If the macro is defined, we have new cabal-install, -- but for some reason we don't have cabal-doctest in package-db -- -- Probably we are running cabal sdist, when otherwise using new-build -- workflow import Warning () #endif import Distribution.Simple main :: IO () main = defaultMain #endif \end{code} lens-action-0.2.2/Warning.hs0000644000000000000000000000040013137001530014041 0ustar0000000000000000module Warning {-# WARNING ["You are configuring this package without cabal-doctest installed.", "The doctests test-suite will not work as a result.", "To fix this, install cabal-doctest before configuring."] #-} () where lens-action-0.2.2/.gitignore0000644000000000000000000000017513137001530014101 0ustar0000000000000000dist/ .hsenv/ docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# .cabal-sandbox/ cabal.sandbox.config codex.tags lens-action-0.2.2/LICENSE0000644000000000000000000000266013137001530013117 0ustar0000000000000000Copyright 2012-2014 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. lens-action-0.2.2/src/0000755000000000000000000000000013137001530012675 5ustar0000000000000000lens-action-0.2.2/src/Control/0000755000000000000000000000000013137001530014315 5ustar0000000000000000lens-action-0.2.2/src/Control/Lens/0000755000000000000000000000000013137001530015216 5ustar0000000000000000lens-action-0.2.2/src/Control/Lens/Action.hs0000644000000000000000000001344613137001530016777 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Action -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Action ( -- * Composable Actions Action , act , acts , perform , performs , liftAct , (^!) , (^!!) , (^!?) -- * Indexed Actions , IndexedAction , iact , iperform , iperforms , (^@!) , (^@!!) , (^@!?) -- * Folds with Effects , MonadicFold , IndexedMonadicFold -- * Implementation Details , Acting , IndexedActing , Effective ) where import Control.Comonad import Control.Lens.Internal.Fold import Control.Lens.Internal.Indexed import Control.Lens.Type import Control.Monad (liftM) import Control.Monad.Trans.Class import Data.Profunctor import Data.Profunctor.Rep #if MIN_VERSION_profunctors(5,0,0) import Data.Profunctor.Sieve #endif import Data.Profunctor.Unsafe import Control.Lens.Action.Internal import Control.Lens.Action.Type -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens infixr 8 ^!, ^!!, ^@!, ^@!!, ^!?, ^@!? -- | Used to evaluate an 'Action'. type Acting m r s a = LensLike (Effect m r) s s a a -- | Perform an 'Action'. -- -- @ -- 'perform' ≡ 'flip' ('^!') -- @ perform :: Monad m => Acting m a s a -> s -> m a perform l = getEffect #. l (Effect #. return) {-# INLINE perform #-} -- | Perform an 'Action' and modify the result. -- -- @ -- 'performs' :: 'Monad' m => 'Acting' m e s a -> (a -> e) -> s -> m e -- @ performs :: (Profunctor p, Monad m) => Over p (Effect m e) s t a b -> p a e -> s -> m e performs l f = getEffect #. l (rmap (Effect #. return) f) {-# INLINE performs #-} -- | Perform an 'Action'. -- -- >>> ["hello","world"]^!folded.act putStrLn -- hello -- world (^!) :: Monad m => s -> Acting m a s a -> m a a ^! l = getEffect (l (Effect #. return) a) {-# INLINE (^!) #-} -- | Perform a 'MonadicFold' and collect all of the results in a list. -- -- >>> ["ab","cd","ef"]^!!folded.acts -- ["ace","acf","ade","adf","bce","bcf","bde","bdf"] -- -- @ -- > [1,2]^!!folded.act (\i -> putStr (show i ++ ": ") >> getLine).each.to succ -- 1: aa -- 2: bb -- "bbcc" -- @ (^!!) :: Monad m => s -> Acting m [a] s a -> m [a] a ^!! l = getEffect (l (Effect #. return . return) a) {-# INLINE (^!!) #-} -- | Perform a 'MonadicFold' and collect the leftmost result. -- -- /Note:/ this still causes all effects for all elements. -- -- >>> [Just 1, Just 2, Just 3]^!?folded.acts -- Just (Just 1) -- >>> [Just 1, Nothing]^!?folded.acts -- Nothing (^!?) :: Monad m => s -> Acting m (Leftmost a) s a -> m (Maybe a) a ^!? l = liftM getLeftmost .# getEffect $ l (Effect #. return . LLeaf) a {-# INLINE (^!?) #-} -- | Construct an 'Action' from a monadic side-effect. -- -- >>> ["hello","world"]^!folded.act (\x -> [x,x ++ "!"]) -- ["helloworld","helloworld!","hello!world","hello!world!"] -- -- @ -- 'act' :: 'Monad' m => (s -> m a) -> 'Action' m s a -- 'act' sma afb a = 'effective' (sma a '>>=' 'ineffective' '.' afb) -- @ act :: Monad m => (s -> m a) -> IndexPreservingAction m s a act sma pafb = cotabulate $ \ws -> effective $ do a <- sma (extract ws) #if MIN_VERSION_profunctors(5,0,0) ineffective (cosieve pafb (a <$ ws)) #else ineffective (corep pafb (a <$ ws)) #endif {-# INLINE act #-} -- | A self-running 'Action', analogous to 'Control.Monad.join'. -- -- @ -- 'acts' ≡ 'act' 'id' -- @ -- -- >>> (1,"hello")^!_2.acts.to succ -- "ifmmp" -- -- @ -- > (1,getLine)^!!_2.acts.folded.to succ -- aa -- "bb" -- @ acts :: IndexPreservingAction m (m a) a acts = act id {-# INLINE acts #-} -- | Apply a 'Monad' transformer to an 'Action'. liftAct :: (MonadTrans trans, Monad m) => Acting m a s a -> IndexPreservingAction (trans m) s a liftAct l = act (lift . perform l) {-# INLINE liftAct #-} ----------------------------------------------------------------------------- -- Indexed Actions ---------------------------------------------------------------------------- -- | Used to evaluate an 'IndexedAction'. type IndexedActing i m r s a = Over (Indexed i) (Effect m r) s s a a -- | Perform an 'IndexedAction'. -- -- @ -- 'iperform' ≡ 'flip' ('^@!') -- @ iperform :: Monad m => IndexedActing i m (i, a) s a -> s -> m (i, a) iperform l = getEffect #. l (Indexed $ \i a -> Effect (return (i, a))) {-# INLINE iperform #-} -- | Perform an 'IndexedAction' and modify the result. iperforms :: Monad m => IndexedActing i m e s a -> (i -> a -> e) -> s -> m e iperforms l = performs l .# Indexed {-# INLINE iperforms #-} -- | Perform an 'IndexedAction'. (^@!) :: Monad m => s -> IndexedActing i m (i, a) s a -> m (i, a) s ^@! l = getEffect (l (Indexed $ \i a -> Effect (return (i, a))) s) {-# INLINE (^@!) #-} -- | Obtain a list of all of the results of an 'IndexedMonadicFold'. (^@!!) :: Monad m => s -> IndexedActing i m [(i, a)] s a -> m [(i, a)] s ^@!! l = getEffect (l (Indexed $ \i a -> Effect (return [(i, a)])) s) {-# INLINE (^@!!) #-} -- | Perform an 'IndexedMonadicFold' and collect the 'Leftmost' result. -- -- /Note:/ this still causes all effects for all elements. (^@!?) :: Monad m => s -> IndexedActing i m (Leftmost (i, a)) s a -> m (Maybe (i, a)) a ^@!? l = liftM getLeftmost .# getEffect $ l (Indexed $ \i -> Effect #. return . LLeaf . (,) i) a {-# INLINE (^@!?) #-} -- | Construct an 'IndexedAction' from a monadic side-effect. iact :: Monad m => (s -> m (i, a)) -> IndexedAction i m s a iact smia iafb s = effective $ do (i, a) <- smia s ineffective (indexed iafb i a) {-# INLINE iact #-} lens-action-0.2.2/src/Control/Lens/Action/0000755000000000000000000000000013137001530016433 5ustar0000000000000000lens-action-0.2.2/src/Control/Lens/Action/Type.hs0000644000000000000000000000772013137001530017716 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Action.Type -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Action.Type ( -- * Getters and Folds Action , MonadicFold , RelevantMonadicFold -- * Indexed , IndexedAction , IndexedMonadicFold , IndexedRelevantMonadicFold -- * Index-Preserving , IndexPreservingAction , IndexPreservingMonadicFold , IndexPreservingRelevantMonadicFold ) where import Control.Applicative (Applicative) import Control.Lens (Conjoined, Indexable) import Data.Functor.Apply (Apply) import Prelude () import Control.Lens.Action.Internal (Effective) ------------------------------------------------------------------------------- -- Actions ------------------------------------------------------------------------------- -- | An 'Action' is a 'Getter' enriched with access to a 'Monad' for side-effects. -- -- Every 'Getter' can be used as an 'Action'. -- -- You can compose an 'Action' with another 'Action' using ('Prelude..') from the @Prelude@. type Action m s a = forall f r. Effective m r f => (a -> f a) -> s -> f s -- | An 'IndexedAction' is an 'IndexedGetter' enriched with access to a 'Monad' for side-effects. -- -- Every 'Getter' can be used as an 'Action'. -- -- You can compose an 'Action' with another 'Action' using ('Prelude..') from the @Prelude@. type IndexedAction i m s a = forall p f r. (Indexable i p, Effective m r f) => p a (f a) -> s -> f s -- | An 'IndexPreservingAction' can be used as a 'Action', but when composed with an 'IndexedTraversal', -- 'IndexedFold', or 'IndexedLens' yields an 'IndexedMonadicFold', 'IndexedMonadicFold' or 'IndexedAction' respectively. type IndexPreservingAction m s a = forall p f r. (Conjoined p, Effective m r f) => p a (f a) -> p s (f s) ------------------------------------------------------------------------------- -- MonadicFolds ------------------------------------------------------------------------------- -- | A 'MonadicFold' is a 'Fold' enriched with access to a 'Monad' for side-effects. -- -- A 'MonadicFold' can use side-effects to produce parts of the structure being folded (e.g. reading them from file). -- -- Every 'Fold' can be used as a 'MonadicFold', that simply ignores the access to the 'Monad'. -- -- You can compose a 'MonadicFold' with another 'MonadicFold' using ('Prelude..') from the @Prelude@. type MonadicFold m s a = forall f r. (Effective m r f, Applicative f) => (a -> f a) -> s -> f s type RelevantMonadicFold m s a = forall f r. (Effective m r f, Apply f) => (a -> f a) -> s -> f s -- | An 'IndexedMonadicFold' is an 'IndexedFold' enriched with access to a 'Monad' for side-effects. -- -- Every 'IndexedFold' can be used as an 'IndexedMonadicFold', that simply ignores the access to the 'Monad'. -- -- You can compose an 'IndexedMonadicFold' with another 'IndexedMonadicFold' using ('Prelude..') from the @Prelude@. type IndexedMonadicFold i m s a = forall p f r. (Indexable i p, Effective m r f, Applicative f) => p a (f a) -> s -> f s type IndexedRelevantMonadicFold i m s a = forall p f r. (Indexable i p, Effective m r f, Apply f) => p a (f a) -> s -> f s -- | An 'IndexPreservingFold' can be used as a 'Fold', but when composed with an 'IndexedTraversal', -- 'IndexedFold', or 'IndexedLens' yields an 'IndexedFold' respectively. type IndexPreservingMonadicFold m s a = forall p f r. (Conjoined p, Effective m r f, Applicative f) => p a (f a) -> p s (f s) type IndexPreservingRelevantMonadicFold m s a = forall p f r. (Conjoined p, Effective m r f, Apply f) => p a (f a) -> p s (f s) lens-action-0.2.2/src/Control/Lens/Action/Reified.hs0000644000000000000000000001050313137001530020335 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Action.Reified -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Action.Reified where import Control.Applicative import Control.Arrow import qualified Control.Category as Cat import Control.Lens hiding ((<.>)) import Control.Monad import Control.Monad.Reader.Class import Data.Functor.Contravariant import Data.Functor.Bind import Data.Functor.Plus import Data.Profunctor import Data.Semigroup import Control.Lens.Action ------------------------------------------------------------------------------ -- MonadicFold ------------------------------------------------------------------------------ -- | Reify a 'MonadicFold' so it can be stored safely in a container. -- newtype ReifiedMonadicFold m s a = MonadicFold { runMonadicFold :: MonadicFold m s a } instance Profunctor (ReifiedMonadicFold m) where dimap f g l = MonadicFold (to f . runMonadicFold l . to g) {-# INLINE dimap #-} rmap g l = MonadicFold (runMonadicFold l . to g) {-# INLINE rmap #-} lmap f l = MonadicFold (to f . runMonadicFold l) {-# INLINE lmap #-} instance Strong (ReifiedMonadicFold m) where first' l = MonadicFold $ \f (s,c) -> phantom $ runMonadicFold l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = MonadicFold $ \f (c,s) -> phantom $ runMonadicFold l (dimap ((,) c) phantom f) s {-# INLINE second' #-} instance Choice (ReifiedMonadicFold m) where left' (MonadicFold l) = MonadicFold $ to tuplify.beside (folded.l.to Left) (folded.to Right) where tuplify (Left lval) = (Just lval,Nothing) tuplify (Right rval) = (Nothing,Just rval) {-# INLINE left' #-} instance Cat.Category (ReifiedMonadicFold m) where id = MonadicFold id l . r = MonadicFold (runMonadicFold r . runMonadicFold l) {-# INLINE (.) #-} instance Arrow (ReifiedMonadicFold m) where arr f = MonadicFold (to f) {-# INLINE arr #-} first = first' {-# INLINE first #-} second = second' {-# INLINE second #-} instance ArrowChoice (ReifiedMonadicFold m) where left = left' {-# INLINE left #-} right = right' {-# INLINE right #-} instance ArrowApply (ReifiedMonadicFold m) where app = MonadicFold $ \cHandler (argFold,b) -> runMonadicFold (pure b >>> argFold) cHandler (argFold,b) {-# INLINE app #-} instance Functor (ReifiedMonadicFold m s) where fmap f l = MonadicFold (runMonadicFold l.to f) {-# INLINE fmap #-} instance Apply (ReifiedMonadicFold m s) where mf <.> ma = mf &&& ma >>> (MonadicFold $ to (uncurry ($))) {-# INLINE (<.>) #-} instance Applicative (ReifiedMonadicFold m s) where pure a = MonadicFold $ folding $ \_ -> [a] {-# INLINE pure #-} mf <*> ma = mf <.> ma {-# INLINE (<*>) #-} instance Alternative (ReifiedMonadicFold m s) where empty = MonadicFold ignored {-# INLINE empty #-} MonadicFold ma <|> MonadicFold mb = MonadicFold $ to (\x->(x,x)).beside ma mb {-# INLINE (<|>) #-} instance Bind (ReifiedMonadicFold m s) where ma >>- f = ((ma >>^ f) &&& returnA) >>> app {-# INLINE (>>-) #-} instance Monad (ReifiedMonadicFold m s) where return a = MonadicFold $ folding $ \_ -> [a] {-# INLINE return #-} ma >>= f = ((ma >>^ f) &&& returnA) >>> app {-# INLINE (>>=) #-} instance MonadReader s (ReifiedMonadicFold m s) where ask = returnA {-# INLINE ask #-} local f ma = f ^>> ma {-# INLINE local #-} instance MonadPlus (ReifiedMonadicFold m s) where mzero = empty {-# INLINE mzero #-} mplus = (<|>) {-# INLINE mplus #-} instance Semigroup (ReifiedMonadicFold m s a) where (<>) = (<|>) {-# INLINE (<>) #-} instance Monoid (ReifiedMonadicFold m s a) where mempty = MonadicFold ignored {-# INLINE mempty #-} mappend = (<|>) {-# INLINE mappend #-} instance Alt (ReifiedMonadicFold m s) where () = (<|>) {-# INLINE () #-} instance Plus (ReifiedMonadicFold m s) where zero = MonadicFold ignored {-# INLINE zero #-} lens-action-0.2.2/src/Control/Lens/Action/Internal.hs0000644000000000000000000000732613137001530020553 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Action -- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- ---------------------------------------------------------------------------- module Control.Lens.Action.Internal ( -- ** Actions Effective(..) , Effect(..) ) where import Control.Applicative import Control.Applicative.Backwards import Control.Monad import Data.Functor.Bind import Data.Functor.Contravariant import Data.Functor.Identity import Data.Profunctor.Unsafe import Data.Semigroup import Control.Lens.Internal.Getter ------------------------------------------------------------------------------- -- Programming with Effects ------------------------------------------------------------------------------- -- | An 'Effective' 'Functor' ignores its argument and is isomorphic to a 'Monad' wrapped around a value. -- -- That said, the 'Monad' is possibly rather unrelated to any 'Applicative' structure. class (Monad m, Functor f, Contravariant f) => Effective m r f | f -> m r where effective :: m r -> f a ineffective :: f a -> m r instance Effective m r f => Effective m (Dual r) (Backwards f) where effective = Backwards . effective . liftM getDual {-# INLINE effective #-} ineffective = liftM Dual . ineffective . forwards {-# INLINE ineffective #-} instance Effective Identity r (Const r) where effective = Const #. runIdentity {-# INLINE effective #-} ineffective = Identity #. getConst {-# INLINE ineffective #-} instance Effective m r f => Effective m r (AlongsideLeft f b) where effective = AlongsideLeft . effective {-# INLINE effective #-} ineffective = ineffective . getAlongsideLeft {-# INLINE ineffective #-} instance Effective m r f => Effective m r (AlongsideRight f b) where effective = AlongsideRight . effective {-# INLINE effective #-} ineffective = ineffective . getAlongsideRight {-# INLINE ineffective #-} ------------------------------------------------------------------------------ -- Effect ------------------------------------------------------------------------------ -- | Wrap a monadic effect with a phantom type argument. newtype Effect m r a = Effect { getEffect :: m r } -- type role Effect representational nominal phantom instance Functor (Effect m r) where fmap _ (Effect m) = Effect m {-# INLINE fmap #-} instance Contravariant (Effect m r) where contramap _ (Effect m) = Effect m {-# INLINE contramap #-} instance Monad m => Effective m r (Effect m r) where effective = Effect {-# INLINE effective #-} ineffective = getEffect {-# INLINE ineffective #-} instance (Apply m, Semigroup r) => Semigroup (Effect m r a) where Effect ma <> Effect mb = Effect (liftF2 (<>) ma mb) {-# INLINE (<>) #-} instance (Monad m, Monoid r) => Monoid (Effect m r a) where mempty = Effect (return mempty) {-# INLINE mempty #-} Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb) {-# INLINE mappend #-} instance (Apply m, Semigroup r) => Apply (Effect m r) where Effect ma <.> Effect mb = Effect (liftF2 (<>) ma mb) {-# INLINE (<.>) #-} instance (Monad m, Monoid r) => Applicative (Effect m r) where pure _ = Effect (return mempty) {-# INLINE pure #-} Effect ma <*> Effect mb = Effect (liftM2 mappend ma mb) {-# INLINE (<*>) #-} lens-action-0.2.2/tests/0000755000000000000000000000000013137001530013250 5ustar0000000000000000lens-action-0.2.2/tests/doctests.hs0000644000000000000000000000147213137001530015440 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module provides doctests for a project based on the actual versions -- of the packages it was built with. It requires a corresponding Setup.lhs -- to be added to the project ----------------------------------------------------------------------------- module Main where import Build_doctests (flags, pkgs, module_sources) import Data.Foldable (traverse_) import Test.DocTest main :: IO () main = do traverse_ putStrLn args doctest args where args = flags ++ pkgs ++ module_sources