diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,7 @@ +4.14 +---- +* Remove `Cons` and `Snoc` instances for `NonEmpty`. + 4.13.2.1 ------ * Fixed `itraverse_` and `imapM_` returning bottom diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -220,184 +220,6 @@ There are also a couple of hundred examples distributed throughout the haddock documentation. -Operators -========= - -(See [`wiki/Operators`](https://github.com/ekmett/lens/wiki/Operators)) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Combinator(s)w/ ResultStatefulw/ ResultNotes
Control.Lens
view,views,^. - use,uses - View target(s). view works like use over a MonadReader
set, .~<.~.=assign,<.=Replace target(s). <<.~ and - <<.= - return the old value
over,mapOf,%~<%~%=<%=Update target(s). <<%~ and - <<%= - return the old value
id,traverseOf,%%~ - %%= - Update target(s) with an Applicative or auxiliary result
+~<+~+=<+=Add to target(s)
-~<-~-=<-=Subtract from target(s)
*~<*~*=<*=Multiply target(s)
//~<//~//=<//=Divide target(s)
^~<^~^=<^=Raise target(s) to a non-negative Integral power
^^~<^^~^^=<^^=Raise target(s) to an Integral power
**~<**~**=<**=Raise target(s) to an arbitrary power
||~<||~||=<||=Logically or target(s)
&&~<&&~&&=<&&=Logically and target(s)
<>~<<>~<>=<<>=mappend to the target monoidal value(s)
headOf,^? - Return Just the first target or Nothing
toListOf,^.. - Return a list of the target(s)
Control.Lens (Indexed)
iover,imapOf,%@~<%@~%@=<%@=Update target(s) with access to the index.
withIndex,itraverseOf,%%@~ - %%@= - Update target(s) with an Applicative or auxiliary result with access to the index.
Data.Bits.Lens
.|.~<.|.~.|.=<.|.=Bitwise or target(s)
.&.~<.&.~.&.=<.&.=Bitwise and target(s)
System.FilePath.Lens
</>~<</>~</>=<</>=Append a relative path to a FilePath
<.>~<<.>~<.>=<<.>=Append a file extension to a FilePath
- - Contact Information ------------------- diff --git a/benchmarks/alongside.hs b/benchmarks/alongside.hs --- a/benchmarks/alongside.hs +++ b/benchmarks/alongside.hs @@ -70,22 +70,20 @@ -- alongside' :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b') -- {-# INLINE alongside'#-} -compound :: Lens s t a b - -> Lens s' t' a' b' - -> Lens (s,s') (t,t') (a,a') (b,b') +compound :: Lens' s a + -> Lens' s' a' + -> Lens' (s,s') (a,a') compound l r = lens (\(s, s') -> (view l s, view r s')) (\(s, s') (t, t') -> (set l t s, set r t' s')) {-# INLINE compound #-} -compound5 :: Lens s t a b - -> Lens s' t' a' b' - -> Lens s'' t'' a'' b'' - -> Lens s''' t''' a''' b''' - -> Lens s'''' t'''' a'''' b'''' - -> Lens (s, (s', (s'', (s''', s'''')))) - (t, (t', (t'', (t''', t'''')))) +compound5 :: Lens' s a + -> Lens' s' a' + -> Lens' s'' a'' + -> Lens' s''' a''' + -> Lens' s'''' a'''' + -> Lens' (s, (s', (s'', (s''', s'''')))) (a, (a', (a'', (a''', a'''')))) - (b, (b', (b'', (b''', b'''')))) compound5 l l' l'' l''' l'''' = lens (\(s, (s', (s'', (s''', s'''')))) -> (view l s, (view l' s', (view l'' s'', (view l''' s''', view l'''' s'''')))) ) diff --git a/benchmarks/plated.hs b/benchmarks/plated.hs --- a/benchmarks/plated.hs +++ b/benchmarks/plated.hs @@ -2,7 +2,15 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} {-# OPTIONS_GHC -funbox-strict-fields #-} + +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(x,y,z) 1 +#endif + +#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative +#endif + import Control.Lens import Control.DeepSeq import Criterion.Main diff --git a/benchmarks/unsafe.hs b/benchmarks/unsafe.hs --- a/benchmarks/unsafe.hs +++ b/benchmarks/unsafe.hs @@ -6,16 +6,18 @@ import Control.Exception import Criterion.Main -import Criterion.Config +import Criterion.Types (Config(..)) +import Data.Functor.Identity (Identity(..)) + import GHC.Exts overS :: ASetter s t a b -> (a -> b) -> s -> t -overS l f = runMutator . l (Mutator . f) +overS l f = runIdentity . l (Identity . f) {-# INLINE overS #-} mappedS :: ASetter [a] [b] a b -mappedS f = Mutator . map (runMutator . f) +mappedS f = Identity . map (runIdentity . f) {-# INLINE mappedS #-} overU :: ASetter s t a b -> (a -> b) -> s -> t @@ -53,11 +55,11 @@ --l = replicate n (); f = (\ _ -> ()) --l = replicate n (); f = (\ !_ -> ()) -- strange results --l = replicate n (); f = lazy (\_ -> ()) - defaultMainWith config (return ()) + defaultMainWith config [ bench "map safe noinline" $ nf (mapSN f) l , bench "map safe inline" $ nf (mapSI f) l , bench "map unsafe noinline" $ nf (mapUN f) l , bench "map unsafe inline" $ nf (mapUI f) l ] where - config = defaultConfig { cfgSamples = ljust 1000 } + config = defaultConfig { resamples = 1000 } diff --git a/benchmarks/zipper.hs b/benchmarks/zipper.hs deleted file mode 100644 --- a/benchmarks/zipper.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Main - ( main -- :: IO () - ) where - -import Control.Lens -import Criterion.Main - -main :: IO () -main = defaultMain - [ bgroup "rezip" - [ bench "rezip" $ nf tugAndRezip1 ['a'..'z'] - , bench "farthest leftward" $ nf tugAndRezip2 ['a'..'z'] - , bench "leftmost" $ nf tugAndRezip3 ['a'..'z'] - , bench "tugTo" $ nf tugAndRezip4 ['a'..'z'] - ] - , bgroup "zipper creation" - [ bench "over traverse id" $ nf (over traverse id) ['a'..'z'] - , bench "zipper" $ nf zipTraverseRezip ['a'..'z'] - ] - , bgroup "downward" - [ bench "downward _1" $ nf downwardAndRezip1 (['a'..'z'],['z'..'a']) - , bench "fromWithin" $ nf downwardAndRezip2 (['a'..'z'],['z'..'a']) - ] - ] - --- What's the fastest rezip of all? -tugAndRezip1, tugAndRezip2, tugAndRezip3 :: String -> String -tugAndRezip1 xs = zipntugs 25 xs & focus .~ 'a' & rezip -tugAndRezip2 xs = zipntugs 25 xs & focus .~ 'b' & farthest leftward & rezip -tugAndRezip3 xs = zipntugs 25 xs & focus .~ 'c' & leftmost & rezip -tugAndRezip4 xs = zipntugs 25 xs & focus .~ 'd' & tugTo 0 & rezip - -zipntugs i x = zipper x & fromWithin traverse & tugs rightward i - --- How fast is creating and destroying a zipper compared to --- a regular traversal? -zipTraverseRezip x = zipper x & fromWithin traverse & rezip - --- is 'downward' any faster than the composition of traverse? -downwardAndRezip1 :: (String, String) -> (String, String) -downwardAndRezip1 xs = - zipper xs & downward _1 & fromWithin traverse & focus .~ 'h' & rezip -downwardAndRezip2 :: (String, String) -> (String, String) -downwardAndRezip2 xs = - zipper xs & fromWithin (_1.traverse) & focus .~ 'g' & rezip diff --git a/cabal.project b/cabal.project new file mode 100644 --- /dev/null +++ b/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -1,6 +1,6 @@ name: lens category: Data, Lenses, Generics -version: 4.13.2.1 +version: 4.14 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -91,6 +91,7 @@ .travis.yml .gitignore .vim.custom + cabal.project examples/LICENSE examples/lens-examples.cabal examples/*.hs @@ -109,7 +110,7 @@ source-repository head type: git - location: git://github.com/ekmett/lens.git + location: https://github.com/ekmett/lens.git -- Enable benchmarking against Neil Mitchell's uniplate library for comparative performance analysis. Defaults to being turned off to avoid -- the extra dependency. @@ -315,7 +316,7 @@ -- hack around the buggy unused matches check for class associated types in ghc 8 rc1 if impl(ghc >= 8) - ghc-options: -fno-warn-missing-pat-syn-sigs -fno-warn-unused-matches + ghc-options: -Wno-missing-pattern-synonym-signatures -Wno-unused-matches if flag(j) && impl(ghc>=7.8) ghc-options: -j4 @@ -452,8 +453,7 @@ hs-source-dirs: benchmarks build-depends: base, - comonad, - comonads-fd, + comonad >= 4, criterion, deepseq, lens, @@ -497,25 +497,8 @@ hs-source-dirs: benchmarks build-depends: base, - comonad, - comonads-fd, - criterion, - deepseq, - generic-deriving, - lens, - transformers - --- Benchmarking zipper usage -benchmark zipper - type: exitcode-stdio-1.0 - main-is: zipper.hs - ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields - hs-source-dirs: benchmarks - build-depends: - base, - comonad, - comonads-fd, - criterion, + comonad >= 4, + criterion >= 1, deepseq, generic-deriving, lens, diff --git a/src/Control/Lens/Cons.hs b/src/Control/Lens/Cons.hs --- a/src/Control/Lens/Cons.hs +++ b/src/Control/Lens/Cons.hs @@ -52,8 +52,6 @@ import Control.Lens.Type import qualified Data.ByteString as StrictB import qualified Data.ByteString.Lazy as LazyB -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty import Data.Monoid import qualified Data.Sequence as Seq import Data.Sequence hiding ((<|), (|>), (:<), (:>)) @@ -121,12 +119,6 @@ [] -> Left [] {-# INLINE _Cons #-} -instance a~b => Cons (NonEmpty a) (NonEmpty b) a b where - _Cons = prism' (uncurry NonEmpty.cons) $ \ xyz -> case xyz of - (x:|y:z) -> Just (x,y:|z) - _ -> Nothing - {-# INLINE _Cons #-} - instance Cons (Seq a) (Seq b) a b where _Cons = prism (uncurry (Seq.<|)) $ \aas -> case viewl aas of a Seq.:< as -> Right (a, as) @@ -351,12 +343,6 @@ then Left [] else Right (Prelude.init aas, Prelude.last aas) {-# INLINE _Snoc #-} - -instance a~b => Snoc (NonEmpty a) (NonEmpty b) a b where - _Snoc = prism' (\(x:|y,z) -> x:|y++[z]) $ \xyz -> case xyz of - x:|y - | Prelude.null y -> Nothing - | otherwise -> Just (x :| Prelude.init y, Prelude.last y) instance Snoc (Seq a) (Seq b) a b where _Snoc = prism (uncurry (Seq.|>)) $ \aas -> case viewr aas of diff --git a/src/Control/Lens/Getter.hs b/src/Control/Lens/Getter.hs --- a/src/Control/Lens/Getter.hs +++ b/src/Control/Lens/Getter.hs @@ -48,6 +48,16 @@ -- Since it is only a function, every 'Getter' obviously only retrieves a -- single value for a given input. -- +-- A common question is whether you can combine multiple 'Getter's to +-- retrieve multiple values. Recall that all 'Getter's are 'Fold's and that +-- we have a @'Monoid' m => 'Applicative' ('Const' m)@ instance to play +-- with. Knowing this, we can use @'Data.Monoid.<>'@ to glue 'Fold's +-- together: +-- +-- >>> import Data.Monoid +-- >>> (1, 2, 3, 4, 5) ^.. (_2 <> _3 <> _5) +-- [2,3,5] +-- ------------------------------------------------------------------------------- module Control.Lens.Getter ( diff --git a/src/Control/Lens/Internal/Zoom.hs b/src/Control/Lens/Internal/Zoom.hs --- a/src/Control/Lens/Internal/Zoom.hs +++ b/src/Control/Lens/Internal/Zoom.hs @@ -1,10 +1,12 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ < 708 +{-# LANGUAGE Trustworthy #-} +#endif + {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-} ----------------------------------------------------------------------------- -- | @@ -19,15 +21,14 @@ module Control.Lens.Internal.Zoom ( -- * Zoom - Zoomed - , Focusing(..) + Focusing(..) , FocusingWith(..) , FocusingPlus(..) , FocusingOn(..) , FocusingMay(..), May(..) , FocusingErr(..), Err(..) + , FocusingFree(..), Freed(..) -- * Magnify - , Magnified , Effect(..) , EffectRWS(..) ) where @@ -36,42 +37,13 @@ import Control.Category import Control.Comonad import Control.Monad.Reader as Reader -import Control.Monad.Trans.State.Lazy as Lazy -import Control.Monad.Trans.State.Strict as Strict -import Control.Monad.Trans.Writer.Lazy as Lazy -import Control.Monad.Trans.Writer.Strict as Strict -import Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Error -import Control.Monad.Trans.Except -import Control.Monad.Trans.List -import Control.Monad.Trans.Identity -import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Free import Data.Functor.Bind import Data.Functor.Contravariant import Data.Semigroup import Prelude hiding ((.),id) ------------------------------------------------------------------------------ --- Zoomed ------------------------------------------------------------------------------- - --- | This type family is used by 'Control.Lens.Zoom.Zoom' to describe the common effect type. -type family Zoomed (m :: * -> *) :: * -> * -> * -type instance Zoomed (Strict.StateT s z) = Focusing z -type instance Zoomed (Lazy.StateT s z) = Focusing z -type instance Zoomed (ReaderT e m) = Zoomed m -type instance Zoomed (IdentityT m) = Zoomed m -type instance Zoomed (Strict.RWST r w s z) = FocusingWith w z -type instance Zoomed (Lazy.RWST r w s z) = FocusingWith w z -type instance Zoomed (Strict.WriterT w m) = FocusingPlus w (Zoomed m) -type instance Zoomed (Lazy.WriterT w m) = FocusingPlus w (Zoomed m) -type instance Zoomed (ListT m) = FocusingOn [] (Zoomed m) -type instance Zoomed (MaybeT m) = FocusingMay (Zoomed m) -type instance Zoomed (ErrorT e m) = FocusingErr e (Zoomed m) -type instance Zoomed (ExceptT e m) = FocusingErr e (Zoomed m) - ------------------------------------------------------------------------------- -- Focusing ------------------------------------------------------------------------------ @@ -256,16 +228,48 @@ {-# INLINE (<*>) #-} ------------------------------------------------------------------------------ --- Magnified +-- Freed ------------------------------------------------------------------------------ --- | This type family is used by 'Control.Lens.Zoom.Magnify' to describe the common effect type. -type family Magnified (m :: * -> *) :: * -> * -> * -type instance Magnified (ReaderT b m) = Effect m -type instance Magnified ((->)b) = Const -type instance Magnified (Strict.RWST a w s m) = EffectRWS w s m -type instance Magnified (Lazy.RWST a w s m) = EffectRWS w s m -type instance Magnified (IdentityT m) = Magnified m +-- | Make a 'Monoid' out of 'FreeF' for result collection. + +newtype Freed f m a = Freed { getFreed :: FreeF f a (FreeT f m a) } + +instance (Applicative f, Semigroup a, Monad m) => Semigroup (Freed f m a) where + Freed (Pure a) <> Freed (Pure b) = Freed $ Pure $ a <> b + Freed (Pure a) <> Freed (Free g) = Freed $ Free $ liftA2 (liftM2 (<>)) (pure $ return a) g + Freed (Free f) <> Freed (Pure b) = Freed $ Free $ liftA2 (liftM2 (<>)) f (pure $ return b) + Freed (Free f) <> Freed (Free g) = Freed $ Free $ liftA2 (liftM2 (<>)) f g + +instance (Applicative f, Monoid a, Monad m) => Monoid (Freed f m a) where + mempty = Freed $ Pure mempty + + Freed (Pure a) `mappend` Freed (Pure b) = Freed $ Pure $ a `mappend` b + Freed (Pure a) `mappend` Freed (Free g) = Freed $ Free $ liftA2 (liftM2 mappend) (pure $ return a) g + Freed (Free f) `mappend` Freed (Pure b) = Freed $ Free $ liftA2 (liftM2 mappend) f (pure $ return b) + Freed (Free f) `mappend` Freed (Free g) = Freed $ Free $ liftA2 (liftM2 mappend) f g + +------------------------------------------------------------------------------ +-- FocusingFree +------------------------------------------------------------------------------ + +-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into +-- 'Control.Monad.Trans.FreeT' +newtype FocusingFree f m k s a = FocusingFree { unfocusingFree :: k (Freed f m s) a } + +instance Functor (k (Freed f m s)) => Functor (FocusingFree f m k s) where + fmap f (FocusingFree as) = FocusingFree (fmap f as) + {-# INLINE fmap #-} + +instance Apply (k (Freed f m s)) => Apply (FocusingFree f m k s) where + FocusingFree kf <.> FocusingFree ka = FocusingFree (kf <.> ka) + {-# INLINE (<.>) #-} + +instance Applicative (k (Freed f m s)) => Applicative (FocusingFree f m k s) where + pure = FocusingFree . pure + {-# INLINE pure #-} + FocusingFree kf <*> FocusingFree ka = FocusingFree (kf <*> ka) + {-# INLINE (<*>) #-} ----------------------------------------------------------------------------- --- Effect diff --git a/src/Control/Lens/Lens.hs b/src/Control/Lens/Lens.hs --- a/src/Control/Lens/Lens.hs +++ b/src/Control/Lens/Lens.hs @@ -545,7 +545,7 @@ -- | Modify the target of a 'Lens' and return the result. -- --- When you do not need the result of the addition, ('Control.Lens.Setter.%~') is more flexible. +-- When you do not need the result of the operation, ('Control.Lens.Setter.%~') is more flexible. -- -- @ -- ('<%~') :: 'Lens' s t a b -> (a -> b) -> s -> (b, t) diff --git a/src/Control/Lens/TH.hs b/src/Control/Lens/TH.hs --- a/src/Control/Lens/TH.hs +++ b/src/Control/Lens/TH.hs @@ -797,8 +797,11 @@ -- Recurse into instance declarations because they main contain -- associated data family instances. - InstanceD ctx inst body -> InstanceD ctx inst <$> traverse go body - +#if MIN_VERSION_template_haskell(2,11,0) + InstanceD moverlap ctx inst body -> InstanceD moverlap ctx inst <$> traverse go body +#else + InstanceD ctx inst body -> InstanceD ctx inst <$> traverse go body +#endif _ -> pure dec stripFields :: Dec -> Dec diff --git a/src/Control/Lens/Zoom.hs b/src/Control/Lens/Zoom.hs --- a/src/Control/Lens/Zoom.hs +++ b/src/Control/Lens/Zoom.hs @@ -29,8 +29,10 @@ -- ------------------------------------------------------------------------------- module Control.Lens.Zoom - ( Magnify(..) + ( Magnified + , Magnify(..) , Zoom(..) + , Zoomed ) where import Control.Lens.Getter @@ -50,6 +52,7 @@ import Control.Monad.Trans.List import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Free import Data.Monoid import Data.Profunctor.Unsafe import Prelude @@ -71,10 +74,46 @@ -- Chosen so that they have lower fixity than ('%='), and to match ('<~'). infixr 2 `zoom`, `magnify` +------------------------------------------------------------------------------ +-- Zoomed +------------------------------------------------------------------------------ + +-- | This type family is used by 'Control.Lens.Zoom.Zoom' to describe the common effect type. +type family Zoomed (m :: * -> *) :: * -> * -> * +type instance Zoomed (Strict.StateT s z) = Focusing z +type instance Zoomed (Lazy.StateT s z) = Focusing z +type instance Zoomed (ReaderT e m) = Zoomed m +type instance Zoomed (IdentityT m) = Zoomed m +type instance Zoomed (Strict.RWST r w s z) = FocusingWith w z +type instance Zoomed (Lazy.RWST r w s z) = FocusingWith w z +type instance Zoomed (Strict.WriterT w m) = FocusingPlus w (Zoomed m) +type instance Zoomed (Lazy.WriterT w m) = FocusingPlus w (Zoomed m) +type instance Zoomed (ListT m) = FocusingOn [] (Zoomed m) +type instance Zoomed (MaybeT m) = FocusingMay (Zoomed m) +type instance Zoomed (ErrorT e m) = FocusingErr e (Zoomed m) +type instance Zoomed (ExceptT e m) = FocusingErr e (Zoomed m) +type instance Zoomed (FreeT f m) = FocusingFree f m (Zoomed m) + +------------------------------------------------------------------------------ +-- Magnified +------------------------------------------------------------------------------ + +-- | This type family is used by 'Control.Lens.Zoom.Magnify' to describe the common effect type. +type family Magnified (m :: * -> *) :: * -> * -> * +type instance Magnified (ReaderT b m) = Effect m +type instance Magnified ((->)b) = Const +type instance Magnified (Strict.RWST a w s m) = EffectRWS w s m +type instance Magnified (Lazy.RWST a w s m) = EffectRWS w s m +type instance Magnified (IdentityT m) = Magnified m + +------------------------------------------------------------------------------ +-- Zoom +------------------------------------------------------------------------------ + -- | This class allows us to use 'zoom' in, changing the 'State' supplied by -- many different 'Control.Monad.Monad' transformers, potentially quite -- deep in a 'Monad' transformer stack. -class (Zoomed m ~ Zoomed n, MonadState s m, MonadState t n) => Zoom m n s t | m -> s, n -> t, m t -> n, n s -> m where +class (MonadState s m, MonadState t n) => Zoom m n s t | m -> s, n -> t, m t -> n, n s -> m where -- | Run a monadic action in a larger 'State' than it was defined in, -- using a 'Lens'' or 'Control.Lens.Traversal.Traversal''. -- @@ -160,6 +199,13 @@ instance Zoom m n s t => Zoom (ExceptT e m) (ExceptT e n) s t where zoom l = ExceptT . liftM getErr . zoom (\afb -> unfocusingErr #. l (FocusingErr #. afb)) . liftM Err . runExceptT {-# INLINE zoom #-} + +instance (Functor f, Zoom m n s t) => Zoom (FreeT f m) (FreeT f n) s t where + zoom l = FreeT . liftM (fmap $ zoom l) . liftM getFreed . zoom (\afb -> unfocusingFree #. l (FocusingFree #. afb)) . liftM Freed . runFreeT + +------------------------------------------------------------------------------ +-- Magnify +------------------------------------------------------------------------------ -- TODO: instance Zoom m m a a => Zoom (ContT r m) (ContT r m) a a where diff --git a/src/Language/Haskell/TH/Lens.hs b/src/Language/Haskell/TH/Lens.hs --- a/src/Language/Haskell/TH/Lens.hs +++ b/src/Language/Haskell/TH/Lens.hs @@ -125,6 +125,13 @@ , _RecGadtC #endif #if MIN_VERSION_template_haskell(2,11,0) + -- ** Overlap Prisms + ,_Overlappable + ,_Overlapping + ,_Overlaps + ,_Incoherent +#endif +#if MIN_VERSION_template_haskell(2,11,0) -- ** SourceUnpackedness Prisms , _NoSourceUnpackedness , _SourceNoUnpack @@ -848,13 +855,52 @@ remitter (ClassD x y z w u) = Just (x, y, z, w, u) remitter _ = Nothing +#if MIN_VERSION_template_haskell(2,11,0) +_InstanceD :: Prism' Dec (Maybe Overlap, Cxt, Type, [Dec]) +#else _InstanceD :: Prism' Dec (Cxt, Type, [Dec]) +#endif _InstanceD = prism' reviewer remitter where +#if MIN_VERSION_template_haskell(2,11,0) + reviewer (x, y, z, w) = InstanceD x y z w + remitter (InstanceD x y z w) = Just (x, y, z, w) +#else reviewer (x, y, z) = InstanceD x y z - remitter (InstanceD x y z) = Just (x, y, z) + remitter (InstanceD x y z) = Just ( x, y, z) +#endif remitter _ = Nothing + +#if MIN_VERSION_template_haskell(2,11,0) +_Overlappable :: Prism' Overlap () +_Overlappable = prism' reviewer remitter + where + reviewer () = Overlappable + remitter Overlappable = Just () + remitter _ = Nothing + +_Overlapping :: Prism' Overlap () +_Overlapping = prism' reviewer remitter + where + reviewer () = Overlapping + remitter Overlapping = Just () + remitter _ = Nothing + +_Overlaps :: Prism' Overlap () +_Overlaps = prism' reviewer remitter + where + reviewer () = Overlaps + remitter Overlaps = Just () + remitter _ = Nothing + +_Incoherent :: Prism' Overlap () +_Incoherent = prism' reviewer remitter + where + reviewer () = Incoherent + remitter Incoherent = Just () + remitter _ = Nothing +#endif _SigD :: Prism' Dec (Name, Type) _SigD