diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1.0.0 + +[#105](https://github.com/stevenfontanella/microlens/issues/105) microlens-pro initial release, with `Prism`s and `Iso`s. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright (c) 2013-2016 Edward Kmett, + 2015-2016 Artyom Kazak, + 2018 Monadfix + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Monadfix nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/microlens-pro.cabal b/microlens-pro.cabal new file mode 100644 --- /dev/null +++ b/microlens-pro.cabal @@ -0,0 +1,90 @@ +name: microlens-pro +version: 0.1.0 +synopsis: Prisms and isomorphisms for microlens +description: + This package provides lens-compatible 'Prism' and 'Iso'. Consequently, it + depends on the rather heavy @profunctors@. + . + Thank you to the contributors + for the original code and some docs, + Emily Pillmore () and + Mario Román () for + + which inspired documentation, and Wikibooks contributors for + . + . + This package is a part of the + family; see the + readme . +license: BSD3 +license-file: LICENSE +author: Edward Kmett, Artyom Kazak, crumbtoo +maintainer: Steven Fontanella +homepage: http://github.com/stevenfontanella/microlens +bug-reports: http://github.com/stevenfontanella/microlens/issues +category: Data, Lenses +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >=1.10 + +tested-with: + GHC==9.8.1 + GHC==9.6.3 + GHC==9.4.7 + GHC==9.2.8 + GHC==9.0.2 + GHC==8.10.7 + GHC==8.8.4 + GHC==8.6.5 + GHC==8.4.4 + GHC==8.2.2 + GHC==8.0.2 + GHC==7.10.3 + +source-repository head + type: git + location: git://github.com/stevenfontanella/microlens.git + +library + exposed-modules: Lens.Micro.Pro + Lens.Micro.ProCompat + Lens.Micro.Pro.TH + Lens.Micro.Pro.Internal + Lens.Micro.Pro.Type + + -- other-modules: + -- other-extensions: + build-depends: base >=4.5 && <5 + , containers >=0.4.0 && <0.8 + , unordered-containers >=0.2.4 && <0.3 + , microlens >=0.4.11.3 && <0.5 + , microlens-th >=0.4.3.3 && <0.5 + , microlens-contra >=0.1.0 && <0.2 + , microlens-platform >=0.4.3 && <0.5 + , profunctors >=5.2.1 && <6 + , tagged >=0.4.4 && <1 + , template-haskell >=2.7 && <2.22 + , th-abstraction >=0.6.0 && <0.7 + , mtl >=2.2.2 && <2.4 + , text >=1.2 && <2.2 + , vector >=0.12.0 && <0.14 + default-extensions: + RankNTypes + PolyKinds + KindSignatures + FlexibleInstances + + if impl(ghc <= 8.6.5) + build-depends: contravariant >=0.1.0 && <1.5.6 + + ghc-options: + -Wall -fwarn-tabs + -O2 -fdicts-cheap -funbox-strict-fields + -fmax-simplifier-iterations=10 + if impl(ghc >= 8.6.5) + ghc-options: + -Wno-orphans + + hs-source-dirs: src + default-language: Haskell2010 + diff --git a/src/Lens/Micro/Pro.hs b/src/Lens/Micro/Pro.hs new file mode 100644 --- /dev/null +++ b/src/Lens/Micro/Pro.hs @@ -0,0 +1,730 @@ +{-| +Module : Lens.Micro.Pro +Copyright : (C) 2013-2016 Edward Kmett, 2018 Monadfix +License : BSD-style (see the file LICENSE) + +This module is home to lens definitions that require +[profunctors](https://hackage.haskell.org/package/profunctors), most notably +'Iso' and 'Prism'. Depending on 'profunctors' is quite the to bear — one +that includes all dependencies of @microlens-platform@. For this reason, +@microlens-pro@ ships with a compatiblity module "Lens.Micro.ProCompat" which +re-exports the entirety of "Lens.Micro.Platform", but with the profunctor-less +definitions hidden and overridden with profunctor'd definitions from this module. +-} + +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE CPP #-} + +#ifndef MIN_VERSION_GLASGOW_HASKELL +# define MIN_VERSION_GLASGOW_HASKELL(x,y,z,z2) 1 +#endif + +module Lens.Micro.Pro + ( + -- * Iso: Losslessly convert between types + -- $isos-note + Iso, Iso' + -- ** Constructing Isos + , iso + -- ** Iso Combinators + , from + , under + , non, non' + -- ** Common Isos + , _Show + , strict, lazy + , enum + , coerced + , mapping + , packed, unpacked + -- ** Miscellaneous + , AnIso, AnIso' + , cloneIso + , withIso + + -- * Prism: A traversal with zero or one targets + -- $prisms-note + , Prism, Prism' + -- ** Constructing Prisms + , prism, prism' + -- ** Prism Combinators + , nearly + , only + -- ** Common Prisms + , _Left, _Right + , _Just, _Nothing + , _Empty + -- ** Miscellaneous + , APrism, APrism' + , clonePrism + , withPrism + + -- * Review + , AReview + , SimpleReview + , re + , review + , (#) + , unto + ) + where +-------------------------------------------------------------------------------- +import Lens.Micro (has) +import Lens.Micro.Contra +import Lens.Micro.Pro.Type +import Lens.Micro.Pro.Internal +import Control.Monad (guard) +import Control.Monad.Reader.Class +import Data.Coerce +import Data.Maybe +import Data.Tagged +import Data.Functor.Contravariant +import Data.Functor.Identity +import Data.Bifunctor +import Data.Void +import Data.Profunctor +import Data.Profunctor.Unsafe + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,4,0) +import GHC.Exts (TYPE) +#endif + +-- implement instances +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.HashMap.Strict as HashMap.Strict +import qualified Data.Map as Map +import qualified Data.Vector as Vector +-------------------------------------------------------------------------------- + +{- | This type is used for efficient "deconstruction" of an 'Iso', reifying +the type into a concrete pair of inverse functions. From the user's perspective, +a function with an 'AnIso' as an argument is simply expecting a normal 'Iso'. +-} + +type AnIso s t a b = Exchange a b a (Identity b) + -> Exchange a b s (Identity t) + +-- | Monomorphic 'AnIso'. + +type AnIso' s a = AnIso s s a a + +-- | This type is used for effecient "deconstruction" of a 'Prism'. From the +-- user's perspective, a function with an 'AnPrism' as an argument is simply +-- expecting a normal 'Prism'. + +type APrism s t a b = Market a b a (Identity b) -> Market a b s (Identity t) + +-- | Monomorphic 'APrism'. + +type APrism' s a = Market a a a (Identity a) -> Market a a s (Identity s) + +-- | Convert 'AnIso' to 'Iso'. This is useful when you need to store an +-- isomorphism as a data type inside a container and later reconstitute it as an +-- overloaded function. + +cloneIso :: AnIso s t a b -> Iso s t a b +cloneIso k = withIso k $ \sa bt -> iso sa bt + +{-# INLINE cloneIso #-} + +{- $isos-note + +Isos (or isomorphisms) are lenses that convert a value instead of targeting a +part of it; in other words, inside of every list lives a reversed list, inside +of every strict @Text@ lives a lazy @Text@, and inside of every @(a, b)@ lives a +@(b, a)@. Since an isomorphism doesn't lose any information, it's possible to +/reverse/ it and use it in the opposite direction by using @from@: + +@ +from :: Iso' s a -> Iso' a s +from :: Iso s t a b -> Iso t s b a +@ + +Isos are constructed from a pair of inverse functions. For example, assume +lawful instances of 'Show' and 'Read': + +@ +show . read = id +read . show = id +@ + +The isomorphisms defined in this module are true lens-compatible isos. Many of +them share names with the lens-__incompatible__ definitions from +[Lens.Micro](https://hackage.haskell.org/package/microlens-0.4.13.1/docs/Lens-Micro.html#g:5) +and +[Lens.Micro.Platform](https://hackage.haskell.org/package/microlens-platform-0.4.3.4/docs/Lens-Micro-Platform.html). +For convenience, we provide a module "Lens.Micro.ProCompat" which emulates +Lens.Micro.Platform, but uses the lens-compatible isos. + +-} + +-- | Construct an 'Iso' from two inverse functions. + +iso :: (s -> a) -> (b -> t) -> Iso s t a b +iso sa bt = dimap sa (fmap bt) + +{-# INLINE iso #-} + +-- | Invert an 'Iso'. Should you define any 'Iso's, it's expected that they +-- abide by the following law, essentially saying that inverting an 'Iso' twice +-- yields the same 'Iso' you started with. +-- +-- @ +-- 'from' ('from' l) ≡ l +-- @ + +from :: AnIso s t a b -> Iso b a t s +from l = withIso l $ \sa bt -> iso bt sa + +{-# INLINE from #-} + +{- | +Shorthand for @'Lens.Micro.over' '.' 'from'@, e.g. + +@ +s & 'over' ('from' l) f ≡ s & 'under' l f +@ +-} +under :: AnIso s t a b -> (t -> s) -> b -> a +under k = withIso k $ \ sa bt ts -> sa . ts . bt + +{-# INLINE under #-} + +-- | Extract the two functions, @s -> a@ and one @b -> t@ that characterize an +-- 'Iso'. + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,4,0) +withIso :: forall s t a b rep (r :: TYPE rep). + AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r +#else +withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r +#endif +withIso ai k = case ai (Exchange id Identity) of + Exchange sa bt -> k sa (runIdentity #. bt) + +{-# INLINE withIso #-} + +{- | +Lawful instances of 'Show' and 'Read' give rise to this isomorphism. + +@ +>>> 123 & from _Show %~ reverse +321 +>>> "123" & _Show %~ (*2) +"246" +@ +-} + +_Show :: (Read a, Show a) => Iso' String a +_Show = iso read show + +{-# INLINE _Show #-} + +{- | +'enum' is a questionable inclusion, as many (most) 'Enum' instances throw +errors for out-of-bounds integers, but it is occasionally useful when used with +that information in mind. Handle with care! + +>>> 97 ^. enum :: Char +'a' +>>> (-1) ^. enum :: Char +*** Exception: Prelude.chr: bad argument: (-1) +>>> [True,False] ^. mapping (from enum) +[1,0] +-} + +enum :: (Enum a) => Iso' Int a +enum = iso toEnum fromEnum + +{-# INLINE enum #-} + +{- | +'non' lets you “relabel” a 'Maybe' by equating 'Nothing' to an arbitrary value +(which you can choose): + +>>> Just 1 ^. non 0 1 + +>>> Nothing ^. non 0 0 + +The most useful thing about 'non' is that relabeling also works in other +direction. If you try to 'set' the “forbidden” value, it'll be turned to +'Nothing': + +>>> Just 1 & non 0 .~ 0 Nothing + +Setting anything else works just fine: + +>>> Just 1 & non 0 .~ 5 Just 5 + +Same happens if you try to modify a value: + +>>> Just 1 & non 0 %~ subtract 1 Nothing + +>>> Just 1 & non 0 %~ (+ 1) Just 2 + +'non' is often useful when combined with 'at'. For instance, if you have a map +of songs and their playcounts, it makes sense not to store songs with 0 plays in +the map; 'non' can act as a filter that wouldn't pass such entries. + +Decrease playcount of a song to 0, and it'll be gone: + +>>> fromList [("Soon",1),("Yesterday",3)] & at "Soon" . non 0 %~ subtract 1 +fromList [("Yesterday",3)] + +Try to add a song with 0 plays, and it won't be added: + +>>> fromList [("Yesterday",3)] & at "Soon" . non 0 .~ 0 +fromList [("Yesterday",3)] + +But it will be added if you set any other number: + +>>> fromList [("Yesterday",3)] & at "Soon" . non 0 .~ 1 +fromList [("Soon",1),("Yesterday",3)] + +'non' is also useful when working with nested maps. Here a nested map is created +when it's missing: + +>>> Map.empty & at "Dez Mona" . non Map.empty . at "Soon" .~ Just 1 +fromList [("Dez Mona",fromList [("Soon",1)])] + +and here it is deleted when its last entry is deleted (notice that 'non' is used +twice here): + +>>> fromList [("Dez Mona",fromList [("Soon",1)])] & at "Dez Mona" . non Map.empty . at "Soon" . non 0 %~ subtract 1 +fromList [] + +To understand the last example better, observe the flow of values in it: + +* the map goes into @at \"Dez Mona\"@ * the nested map (wrapped into @Just@) +goes into @non Map.empty@ * @Just@ is unwrapped and the nested map goes into @at +\"Soon\"@ * @Just 1@ is unwrapped by @non 0@ + +Then the final value – i.e. 1 – is modified by @subtract 1@ and the result +(which is 0) starts flowing backwards: + +* @non 0@ sees the 0 and produces a @Nothing@ + +* @at \"Soon\"@ sees @Nothing@ and deletes the corresponding value from the map + +* the resulting empty map is passed to @non Map.empty@, which sees that it's +empty and thus produces @Nothing@ + +* @at \"Dez Mona\"@ sees @Nothing@ and removes the key from the map +-} + +non :: (Eq a) => a -> Iso' (Maybe a) a +non a = non' $ only a + +{-# INLINE non #-} + +{- | +'non', but instead of equality with a value, 'non'' equates 'Nothing' to +anything a 'Prism' of your choice doesn't match. + +>>> Just [] & non' _Empty .~ [1,2,3] +Just [1,2,3] +>>> Just [] & non' _Empty .~ [] +Nothing + +See 'non' for cases this may be useful. +-} + +non' :: APrism' a () -> Iso' (Maybe a) a +non' p = iso (fromMaybe def) go where + def = review (clonePrism p) () + go b | has (clonePrism p) b = Nothing + | otherwise = Just b + +{-# INLINE non' #-} + +{- | +Coercible types have the same runtime representation, i.e. they are isomorphic. + +>>> (Sum 123 :: Sum Int) ^. coerced :: Int +123 +-} + +coerced :: forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b +coerced l = rmap (fmap coerce) l .# coerce + +{-# INLINE coerced #-} + +{- | +An isomorphism holds when lifted into a functor. For example, if a list contains +a bunch of @a@'s which are each isomorphic to a @b@, the whole list of @a@'s is +isomorphic to a list of @b@'s. + +>>> ["1","2","3"] ^. mapping _Show :: [Int] +[1,2,3] +>>> ([1,2,3] :: [Int]) ^. from (mapping _Show) +["1","2","3"] + +This also hold across different functors: + +>>> let l = mapping @[] @Maybe _Show +>>> :t l +l :: (Read b, Show b) => Iso [String] (Maybe String) [b] (Maybe b) +>>> ["1","2","3"] & l %~ Just . sum +Just "6" +-} + +mapping :: (Functor f, Functor g) => AnIso s t a b -> Iso (f s) (g t) (f a) (g b) +mapping k = withIso k $ \ sa bt -> iso (fmap sa) (fmap bt) + +{-# INLINE mapping #-} + +-------------------------------------------------------------------------------- + + +{- $prisms-note + +If a 'Lens' views and updates individual components of /product/ types, a +'Prism' views and updates individual components of /sum/ types. For example, you +may want to update the 'Left' field of an 'Either': + +>>> Left "salmon" & _Left .~ "orb" +Left "orb" +>>> Right "pudding" & _Left .~ "orb" +Right "pudding" + +Also similarly to a 'Lens', you might want to view the 'Left' field. However, it +might not always be there, so we treat it as a traversal with either one or zero +results. + +>>> Right "bass" ^? _Left +Nothing +>>> Left "bubbles" ^? _Left +Just "bubbles" + +A unique feature of 'Prism's is that they may be flipped around using 're' to +construct the larger structure. Maintaining our example of 'Either', remember +that you can construct the entire 'Either' via the constructor 'Left'. + +>>> :t re _Left +re _Left :: Getter b (Either b c) +>>> view (re _Left) "bungo" +Left "bungo" + +This @'view' ('re' l)@ idiom isn't the prettiest, so we define @'review' = +'view' . 're'@ as shorthand. 'review' also has an infix synonym, '(#)'. + +>>> :t _Just +_Just :: Prism (Maybe a) (Maybe b) a b +>>> review _Just "bilbo" +Just "bilbo" +>>> _Just # "bilbo" +Just "bilbo" + +As is the whole point of optics, prisms may of course be composed with other +optics: + +@ +type Thing = Either (Maybe String) (Maybe (Either [Bool] Int)) +thing :: Thing +thing = Right (Just (Left [True,False])) +@ +>>> thing & _Right . _Just . _Left . each %~ not +Right (Just (Left [False,True])) + +-} + +{- | +Generate a 'Prism' out of a constructor and a selector. You may wonder +why the selector function returns an 'Either t a' rather than the more obvious +choice of 'Maybe a'; This is to allow @s@ and @t@ to differ — see 'prism''. + +@ +_Left = prism Left $ either Right (Left . Right) +@ +-} + +prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b +prism bt seta = dimap seta (either pure (fmap bt)) . right' + +{-# INLINE prism #-} + +{- | +Generate a 'Prism' out of a constructor and a selector. + +@ +_Nothing = prism Left $ either Right (Left . Right) +@ +-} + +prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b +prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s)) + +{-# INLINE prism' #-} + +{- | +Clone a Prism so that you can reuse the same monomorphically typed Prism for +different purposes. + +Cloning a 'Prism' is one way to make sure you aren't given something weaker, +such as a 'Traversal' and can be used as a way to pass around lenses that have +to be monomorphic in @f@. +-} + +clonePrism :: APrism s t a b -> Prism s t a b +clonePrism k = withPrism k $ \bt sta -> prism bt sta + +{-# INLINE clonePrism #-} + +{- | +Convert a 'Prism' into the constructor and selector that characterise it. See: +'prism'. +-} + +withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r +withPrism k f = case coerce (k (Market Identity Right)) of + Market bt seta -> f bt seta + +{-# INLINE withPrism #-} + +{- | +Focus the 'Just' of a 'Maybe'. This might seem redundant, as: + +>>> Just "pikyben" ^? _Just +Just "pikyben" + +but '_Just' proves useful when composing with other optics. +-} + +_Just :: Prism (Maybe a) (Maybe b) a b +_Just = prism Just $ maybe (Left Nothing) Right + +{-# INLINE _Just #-} + +{- | +'_Nothing' focuses the 'Nothing' in a 'Maybe'. + +>>> Nothing ^? _Nothing +Just () +>>> Just "wassa" ^? _Nothing +Nothing +>>> 'has' _Nothing (Just "something") +False +-} +_Nothing :: Prism' (Maybe a) () +_Nothing = prism' (const Nothing) $ maybe (Just ()) (const Nothing) + +{-# INLINE _Nothing #-} + +{- | +Focus the 'Left' component of an 'Either' + +>>> Left "doge" ^? _Left +Just "doge" +>>> Right "soge" ^? _Left +Nothing +>>> review _Left "quoge" +Left "quoge" +-} + +_Left :: Prism (Either a c) (Either b c) a b +_Left = prism Left $ either Right (Left . Right) + +{-# INLINE _Left #-} + +{- | +Focus the 'Right' component of an 'Either' + +>>> Left "doge" ^? _Right +Nothing +>>> Right "soge" ^? _Right +Just "soge" +>>> review _Right "quoge" +Right "quoge" +-} + +_Right :: Prism (Either c a) (Either c b) a b +_Right = prism Right $ either (Left . Left) Right + +{-# INLINE _Right #-} + +class AsEmpty a where + {- | + A prism that matches the empty structure. + + >>> has _Empty [] + True + -} + _Empty :: Prism' a () + default _Empty :: (Monoid a, Eq a) => Prism' a () + _Empty = only mempty + {-# INLINE _Empty #-} + +instance AsEmpty [a] where + _Empty = nearly [] null + {-# INLINE _Empty #-} + +instance AsEmpty (Map.Map k v) where + _Empty = nearly Map.empty Map.null + {-# INLINE _Empty #-} + +instance AsEmpty (Maybe a) where + _Empty = _Nothing + {-# INLINE _Empty #-} + +instance AsEmpty (HashMap.Strict.HashMap k v) where + _Empty = nearly HashMap.Strict.empty HashMap.Strict.null + {-# INLINE _Empty #-} + +instance AsEmpty (Vector.Vector a) where + _Empty = nearly Vector.empty Vector.null + {-# INLINE _Empty #-} + +instance AsEmpty Text.Text where + _Empty = nearly Text.empty Text.null + {-# INLINE _Empty #-} + +instance AsEmpty Text.Lazy.Text where + _Empty = nearly Text.Lazy.empty Text.Lazy.null + {-# INLINE _Empty #-} + +{- | +A prism that matches equality with a value: + +>>> 1 ^? only 2 +Nothing +>>> 1 ^? only 1 +Just 1 +-} + +only :: Eq a => a -> Prism' a () +only a = prism' (\() -> a) $ guard . (a ==) + +{-# INLINE only #-} + +{- | +@'nearly' a p@ is a prism that matches "loose equality" with @a@ by assuming @p +x@ is true iff @x ≡ a@. + +>>> nearly [] null # () +[] +>>> [1,2,3,4] ^? nearly [] null +Nothing +-} + +nearly :: a -> (a -> Bool) -> Prism' a () +nearly a p = prism' (\() -> a) $ guard . p + +{-# INLINE nearly #-} + +{- | +If you see this in a signature for a function, the function is expecting a +Review. This usually means a 'Prism' or an 'Iso'. +-} +type AReview t b = Tagged b (Identity b) -> Tagged t (Identity t) + +{- | +[@Review@](https://hackage.haskell.org/package/lens-5.2.3/docs/Control-Lens-Type.html#t:Review), +from lens, is limited form of 'Prism' that can only be used for 're' operations. + +Similarly to 'SimpleGetter' from microlens, microlens-pro does not define 'Review' and opts for +a less general 'SimpleReview' in order to avoid a +[distributive](https://hackage.haskell.org/package/distributive-0.6.2.1) +dependency. +-} + +type SimpleReview t b = forall p. (Choice p, Bifunctor p) + => p b (Identity b) -> p t (Identity t) + +{-| +Reverse a 'Prism' or 'Iso' and 'view' it + +@ +review ≡ view . re +@ + +@ +>>> review _Just "sploink" +Just "sploink" +@ + +'review' is often used with the function monad, @((->)r)@: + +@ +review :: AReview t b -> b -> t +@ +-} + +review :: MonadReader b m => AReview t b -> m t +review p = asks (runIdentity #. unTagged #. p .# Tagged .# Identity) + +{-# INLINE review #-} + +{-| +Reverse a 'Prism' or 'Iso' turning it into a getter. 're' is a weaker version of +'from', in that you can't flip it back around after reversing it the first time. + +>>> "hello worms" ^. re _Just +Just "hello worms" +-} + +re :: AReview t b -> Getter b t +re p = to (runIdentity #. unTagged #. p .# Tagged .# Identity) + +{-# INLINE re #-} + +-- | An infix synonym of 'review' +(#) :: AReview t b -> b -> t +(#) p = runIdentity #. unTagged #. p .# Tagged .# Identity + +infixr 8 # +{-# INLINE (#) #-} + +-- TODO: `to` is temporarily defined here. This should be in microlens-contra, +-- or better yet, microlens as Contravariant has been in base since at least ghc +-- 8.6.5. This definition isn't perfect either -- the version from lens is: +-- +-- to :: (Profunctor p, Contravariant f) => (s -> a) -> Optic' p f s a + +to :: (s -> a) -> Getter s a +to k = dimap k (contramap k) + +{-# INLINE to #-} + +{- | +Construct a 'Review' out of a constructor. Consider this more pleasant type +signature: + +@ +unto :: (b -> t) -> Review' t b +@ + +Pardon the actual type signature — microlens defines neither @Optic@ (used in +lens' +[@unto@](https://hackage.haskell.org/package/lens-5.2.3/docs/Control-Lens-Combinators.html#v:unto)) nor @Review'@. Here we simply expand the definition of @Optic@. +-} +unto :: (Profunctor p, Bifunctor p, Functor f) + => (b -> t) + -> p a (f b) -> p s (f t) +unto f = first absurd . lmap absurd . rmap (fmap f) + +{-# INLINE unto #-} + +-------------------------------------------------------------------------------- + +instance IsText [Char] where + packed = id + unpacked = id + + {-# INLINE packed #-} + {-# INLINE unpacked #-} + +instance IsText Text.Text where + packed = iso Text.pack Text.unpack + unpacked = iso Text.unpack Text.pack + + {-# INLINE packed #-} + {-# INLINE unpacked #-} + +instance IsText Text.Lazy.Text where + packed = iso Text.Lazy.pack Text.Lazy.unpack + unpacked = iso Text.Lazy.unpack Text.Lazy.pack + + {-# INLINE packed #-} + {-# INLINE unpacked #-} + diff --git a/src/Lens/Micro/Pro/Internal.hs b/src/Lens/Micro/Pro/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Lens/Micro/Pro/Internal.hs @@ -0,0 +1,116 @@ +{-| +Module : Lens.Micro.Pro.Internal +Copyright : (C) 2013-2016 Edward Kmett, 2018 Monadfix +License : BSD-style (see the file LICENSE) + +Definitions used internally by microlens. If you're going to use these, only +define instances for your own types, and don't export an API using these! +-} +{-# LANGUAGE FunctionalDependencies #-} +module Lens.Micro.Pro.Internal + ( Strict(strict, lazy) + + , IsText(packed, unpacked) + + , Exchange(..), Exchange' + , Market(..), Market' + + , Iso, Iso' + , Prism, Prism' + ) + where +-------------------------------------------------------------------------------- +import Lens.Micro.Pro.Type +import Data.Coerce +import Data.Profunctor +import Data.Profunctor.Unsafe +-------------------------------------------------------------------------------- + +class Strict lazy strict | lazy -> strict, strict -> lazy where + strict :: Iso' lazy strict + lazy :: Iso' strict lazy + +{- | This type is used internally to provide efficient access +to the two inverse functions behind an 'Iso'. +-} + +data Exchange a b s t = Exchange (s -> a) (b -> t) + +type Exchange' a s = Exchange a a s s + +instance Functor (Exchange a b s) where + fmap f (Exchange sa bt) = Exchange sa (f . bt) + {-# INLINE fmap #-} + +instance Profunctor (Exchange a b) where + dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt) + lmap f (Exchange sa bt) = Exchange (sa . f) bt + rmap f (Exchange sa bt) = Exchange sa (f . bt) + + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + + (#.) _ = coerce + (.#) p _ = coerce p + + {-# INLINE (#.) #-} + {-# INLINE (.#) #-} + +{- | This type is used internally by the Prism code to provide efficient access +to the two parts of a Prism, i.e. a constructor and a selector — see: +'Lens.Micro.Pro.prism'. +-} +data Market a b s t = Market (b -> t) (s -> Either t a) + +instance Functor (Market a b s) where + fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) + {-# INLINE fmap #-} + +instance Profunctor (Market a b) where + dimap f g (Market bt seta) = + Market (g . bt) (either (Left . g) Right . seta . f) + + lmap f (Market bt seta) = Market bt (seta . f) + rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) + + {-# INLINE rmap #-} + {-# INLINE lmap #-} + {-# INLINE dimap #-} + + (#.) _ = coerce + (.#) p _ = coerce p + + {-# INLINE (#.) #-} + {-# INLINE (.#) #-} + +instance Choice (Market a b) where + left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of + Left s -> case seta s of + Left t -> Left (Left t) + Right a -> Right a + Right c -> Left (Right c) + + right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of + Left c -> Left (Left c) + Right s -> case seta s of + Left t -> Left (Right t) + Right a -> Right a + + {-# INLINE right' #-} + {-# INLINE left' #-} + +type Market' a s = Market a a s s + +class IsText t where + + -- | 'packed' lets you convert between 'String' and @Text@ (strict or lazy). + -- It can be used as a replacement for @pack@ or as a way to modify some + -- 'String' if you have a function like @Text -> Text@. + + packed :: Iso' String t + + -- | 'unpacked' is like 'packed' but works in the opposite direction. + + unpacked :: Iso' t String + diff --git a/src/Lens/Micro/Pro/TH.hs b/src/Lens/Micro/Pro/TH.hs new file mode 100644 --- /dev/null +++ b/src/Lens/Micro/Pro/TH.hs @@ -0,0 +1,556 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-trustworthy-safe #-} +#endif + +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TemplateHaskellQuotes #-} +#else +{-# LANGUAGE TemplateHaskell #-} +#endif + +{- | +Module : Lens.Micro.Pro.TH +Copyright : (C) 2014-2016 Eric Mertens, Edward Kmett; 2018 Monadfix +License : BSD-style (see the file LICENSE) + +Template Haskell functions to automatically define prisms. +-} +module Lens.Micro.Pro.TH +( + makePrisms, + makeClassyPrisms, +) +where + +import Lens.Micro +import Lens.Micro.Extras +import Lens.Micro.Pro +import Lens.Micro.TH.Internal + (HasTypeVars(..), typeVars, substTypeVars, newNames, conAppsT, inlinePragma) + +import Data.Char (isUpper) +import Data.List +import Data.Monoid +import qualified Data.Set as Set +import Data.Set (Set) +import Data.Traversable +import Language.Haskell.TH +import Language.Haskell.TH.Datatype.TyVarBndr +import qualified Language.Haskell.TH.Datatype as D +import qualified Data.Map as Map + +-- | Generate a 'Prism' for each constructor of a data type. +-- Isos generated when possible. +-- Reviews are created for constructors with existentially +-- quantified constructors and GADTs. +-- +-- /e.g./ +-- +-- @ +-- data FooBarBaz a +-- = Foo Int +-- | Bar a +-- | Baz Int Char +-- makePrisms ''FooBarBaz +-- @ +-- +-- will create +-- +-- @ +-- _Foo :: Prism' (FooBarBaz a) Int +-- _Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b +-- _Baz :: Prism' (FooBarBaz a) (Int, Char) +-- @ +makePrisms :: Name {- ^ Type constructor name -} -> DecsQ +makePrisms = makePrisms' True + +-- | Generate a 'Prism' for each constructor of a data type +-- and combine them into a single class. No Isos are created. +-- Reviews are created for constructors with existentially +-- quantified constructors and GADTs. +-- +-- /e.g./ +-- +-- @ +-- data FooBarBaz a +-- = Foo Int +-- | Bar a +-- | Baz Int Char +-- makeClassyPrisms ''FooBarBaz +-- @ +-- +-- will create +-- +-- @ +-- class AsFooBarBaz s a | s -> a where +-- _FooBarBaz :: Prism' s (FooBarBaz a) +-- _Foo :: Prism' s Int +-- _Bar :: Prism' s a +-- _Baz :: Prism' s (Int,Char) +-- +-- _Foo = _FooBarBaz . _Foo +-- _Bar = _FooBarBaz . _Bar +-- _Baz = _FooBarBaz . _Baz +-- +-- instance AsFooBarBaz (FooBarBaz a) a +-- @ +-- +-- Generate an "As" class of prisms. Names are selected by prefixing the constructor +-- name with an underscore. Constructors with multiple fields will +-- construct Prisms to tuples of those fields. +-- +-- In the event that the name of a data type is also the name of one of its +-- constructors, the name of the 'Prism' generated for the data type will be +-- prefixed with an extra @_@ (if the data type name is prefix) or @.@ (if the +-- name is infix) to disambiguate it from the 'Prism' for the corresponding +-- constructor. For example, this code: +-- +-- @ +-- data Quux = Quux Int | Fred Bool +-- makeClassyPrisms ''Quux +-- @ +-- +-- will create: +-- +-- @ +-- class AsQuux s where +-- __Quux :: Prism' s Quux -- Data type prism +-- _Quux :: Prism' s Int -- Constructor prism +-- _Fred :: Prism' s Bool +-- +-- _Quux = __Quux . _Quux +-- _Fred = __Quux . _Fred +-- +-- instance AsQuux Quux +-- @ +makeClassyPrisms :: Name {- ^ Type constructor name -} -> DecsQ +makeClassyPrisms = makePrisms' False + +-- | Main entry point into Prism generation for a given type constructor name. +makePrisms' :: Bool -> Name -> DecsQ +makePrisms' normal typeName = + do info <- D.reifyDatatype typeName + let cls | normal = Nothing + | otherwise = Just (D.datatypeName info) + cons = D.datatypeCons info + makeConsPrisms (D.datatypeType info) (map normalizeCon cons) cls + + +-- | Generate prisms for the given type, normalized constructors, and +-- an optional name to be used for generating a prism class. +-- This function dispatches between Iso generation, normal top-level +-- prisms, and classy prisms. +makeConsPrisms :: Type -> [NCon] -> Maybe Name -> DecsQ + +-- special case: single constructor, not classy -> make iso +makeConsPrisms t [con@(NCon _ [] [] _)] Nothing = makeConIso t con + +-- top-level definitions +makeConsPrisms t cons Nothing = + fmap concat $ for cons $ \con -> + do let conName = view nconName con + stab <- computeOpticType t cons con + let n = prismName conName + sequenceA + ( [ sigD n (close (stabToType stab)) + , valD (varP n) (normalB (makeConOpticExp stab cons con)) [] + ] + ++ inlinePragma n + ) + + +-- classy prism class and instance +makeConsPrisms t cons (Just typeName) = + sequenceA + [ makeClassyPrismClass t className methodName cons + , makeClassyPrismInstance t className methodName cons + ] + where + typeNameBase = nameBase typeName + className = mkName ("As" ++ typeNameBase) + sameNameAsCon = any (\con -> nameBase (view nconName con) == typeNameBase) cons + methodName = prismName' sameNameAsCon typeName + + +data OpticType = PrismType | ReviewType +data Stab = Stab Cxt OpticType Type Type Type Type + +simplifyStab :: Stab -> Stab +simplifyStab (Stab cx ty _ t _ b) = Stab cx ty t t b b + -- simplification uses t and b because those types + -- are interesting in the Review case + +stabSimple :: Stab -> Bool +stabSimple (Stab _ _ s t a b) = s == t && a == b + +stabToType :: Stab -> Type +stabToType stab@(Stab cx ty s t a b) = ForallT vs cx $ + case ty of + PrismType | stabSimple stab -> ''Prism' `conAppsT` [t,b] + | otherwise -> ''Prism `conAppsT` [s,t,a,b] + ReviewType -> ''AReview `conAppsT` [t,b] + + where + vs = map plainTVInferred + $ nub -- stable order + $ toListOf typeVars cx + +stabType :: Stab -> OpticType +stabType (Stab _ o _ _ _ _) = o + +computeOpticType :: Type -> [NCon] -> NCon -> Q Stab +computeOpticType t cons con = + do let cons' = delete con cons + if null (_nconVars con) + then computePrismType t (view nconCxt con) cons' con + else computeReviewType t (view nconCxt con) (view nconTypes con) + + +computeReviewType :: Type -> Cxt -> [Type] -> Q Stab +computeReviewType s' cx tys = + do let t = s' + s <- fmap VarT (newName "s") + a <- fmap VarT (newName "a") + b <- toTupleT (map return tys) + return (Stab cx ReviewType s t a b) + + +-- | Compute the full type-changing Prism type given an outer type, +-- list of constructors, and target constructor name. Additionally +-- return 'True' if the resulting type is a "simple" prism. +computePrismType :: Type -> Cxt -> [NCon] -> NCon -> Q Stab +computePrismType t cx cons con = + do let ts = view nconTypes con + unbound = setOf typeVars t Set.\\ setOf typeVars cons + sub <- sequenceA (fromSet (newName . nameBase) unbound) + b <- toTupleT (map return ts) + a <- toTupleT (map return (substTypeVars sub ts)) + let s = substTypeVars sub t + return (Stab cx PrismType s t a b) + + +computeIsoType :: Type -> [Type] -> TypeQ +computeIsoType t' fields = + do sub <- sequenceA (fromSet (newName . nameBase) (setOf typeVars t')) + let t = return t' + s = return (substTypeVars sub t') + b = toTupleT (map return fields) + a = toTupleT (map return (substTypeVars sub fields)) + ty | Map.null sub = appsT (conT ''Iso') [t,b] + | otherwise = appsT (conT ''Iso) [s,t,a,b] + + close =<< ty + + + +-- | Construct either a Review or Prism as appropriate +makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ +makeConOpticExp stab cons con = + case stabType stab of + PrismType -> makeConPrismExp stab cons con + ReviewType -> makeConReviewExp con + + +-- | Construct an iso declaration +makeConIso :: Type -> NCon -> DecsQ +makeConIso s con = + do let ty = computeIsoType s (view nconTypes con) + defName = prismName (view nconName con) + sequenceA + ( [ sigD defName ty + , valD (varP defName) (normalB (makeConIsoExp con)) [] + ] ++ + inlinePragma defName + ) + + +-- | Construct prism expression +-- +-- prism <> <> +makeConPrismExp :: + Stab -> + [NCon] {- ^ constructors -} -> + NCon {- ^ target constructor -} -> + ExpQ +makeConPrismExp stab cons con = appsE [varE 'prism, reviewer, remitter] + where + ts = view nconTypes con + fields = length ts + conName = view nconName con + + reviewer = makeReviewer conName fields + remitter | stabSimple stab = makeSimpleRemitter conName fields + | otherwise = makeFullRemitter cons conName + + +-- | Construct an Iso expression +-- +-- iso <> <> +makeConIsoExp :: NCon -> ExpQ +makeConIsoExp con = appsE [varE 'iso, remitter, reviewer] + where + conName = view nconName con + fields = length (view nconTypes con) + + reviewer = makeReviewer conName fields + remitter = makeIsoRemitter conName fields + + +-- | Construct a Review expression +-- +-- unto (\(x,y,z) -> Con x y z) +makeConReviewExp :: NCon -> ExpQ +makeConReviewExp con = appE (varE 'unto) reviewer + where + conName = view nconName con + fields = length (view nconTypes con) + + reviewer = makeReviewer conName fields + + +------------------------------------------------------------------------ +-- Prism and Iso component builders +------------------------------------------------------------------------ + + +-- | Construct the review portion of a prism. +-- +-- (\(x,y,z) -> Con x y z) :: b -> t +makeReviewer :: Name -> Int -> ExpQ +makeReviewer conName fields = + do xs <- newNames "x" fields + lam1E (toTupleP (map varP xs)) + (conE conName `appsE1` map varE xs) + + +-- | Construct the remit portion of a prism. +-- Pattern match only target constructor, no type changing +-- +-- (\x -> case s of +-- Con x y z -> Right (x,y,z) +-- _ -> Left x +-- ) :: s -> Either s a +makeSimpleRemitter :: Name -> Int -> ExpQ +makeSimpleRemitter conName fields = + do x <- newName "x" + xs <- newNames "y" fields + let matches = + [ match (conP conName (map varP xs)) + (normalB (appE (conE 'Right) (toTupleE (map varE xs)))) + [] + , match wildP (normalB (appE (conE 'Left) (varE x))) [] + ] + lam1E (varP x) (caseE (varE x) matches) + + +-- | Pattern match all constructors to enable type-changing +-- +-- (\x -> case s of +-- Con x y z -> Right (x,y,z) +-- Other_n w -> Left (Other_n w) +-- ) :: s -> Either t a +makeFullRemitter :: [NCon] -> Name -> ExpQ +makeFullRemitter cons target = + do x <- newName "x" + lam1E (varP x) (caseE (varE x) (map mkMatch cons)) + where + mkMatch (NCon conName _ _ n) = + do xs <- newNames "y" (length n) + match (conP conName (map varP xs)) + (normalB + (if conName == target + then appE (conE 'Right) (toTupleE (map varE xs)) + else appE (conE 'Left) (conE conName `appsE1` map varE xs))) + [] + + +-- | Construct the remitter suitable for use in an 'Iso' +-- +-- (\(Con x y z) -> (x,y,z)) :: s -> a +makeIsoRemitter :: Name -> Int -> ExpQ +makeIsoRemitter conName fields = + do xs <- newNames "x" fields + lam1E (conP conName (map varP xs)) + (toTupleE (map varE xs)) + + +------------------------------------------------------------------------ +-- Classy prisms +------------------------------------------------------------------------ + + +-- | Construct the classy prisms class for a given type and constructors. +-- +-- class ClassName r <> | r -> <> where +-- topMethodName :: Prism' r Type +-- conMethodName_n :: Prism' r conTypes_n +-- conMethodName_n = topMethodName . conMethodName_n +makeClassyPrismClass :: + Type {- Outer type -} -> + Name {- Class name -} -> + Name {- Top method name -} -> + [NCon] {- Constructors -} -> + DecQ +makeClassyPrismClass t className methodName cons = + do r <- newName "r" + let methodType = appsT (conT ''Prism') [varT r,return t] + methodss <- traverse (mkMethod (VarT r)) cons' + classD (cxt[]) className (map plainTV (r : vs)) (fds r) + ( sigD methodName methodType + : map return (concat methodss) + ) + + where + mkMethod r con = + do Stab cx o _ _ _ b <- computeOpticType t cons con + let stab' = Stab cx o r r b b + defName = view nconName con + body = appsE [varE '(.), varE methodName, varE defName] + sequenceA + [ sigD defName (return (stabToType stab')) + , valD (varP defName) (normalB body) [] + ] + + cons' = map (over nconName prismName) cons + vs = Set.toList (setOf typeVars t) + fds r + | null vs = [] + | otherwise = [FunDep [r] vs] + + + +-- | Construct the classy prisms instance for a given type and constructors. +-- +-- instance Classname OuterType where +-- topMethodName = id +-- conMethodName_n = <> +makeClassyPrismInstance :: + Type -> + Name {- Class name -} -> + Name {- Top method name -} -> + [NCon] {- Constructors -} -> + DecQ +makeClassyPrismInstance s className methodName cons = + do let vs = Set.toList (setOf typeVars s) + cls = className `conAppsT` (s : map VarT vs) + + instanceD (cxt[]) (return cls) + ( valD (varP methodName) + (normalB (varE 'id)) [] + : [ do stab <- computeOpticType s cons con + let stab' = simplifyStab stab + valD (varP (prismName conName)) + (normalB (makeConOpticExp stab' cons con)) [] + | con <- cons + , let conName = view nconName con + ] + ) + + +------------------------------------------------------------------------ +-- Utilities +------------------------------------------------------------------------ + + +-- | Normalized constructor +data NCon = NCon + { _nconName :: Name + , _nconVars :: [Name] + , _nconCxt :: Cxt + , _nconTypes :: [Type] + } + deriving (Eq) + +nconName :: Lens' NCon Name +nconName f x = fmap (\y -> x {_nconName = y}) (f (_nconName x)) + +nconCxt :: Lens' NCon Cxt +nconCxt f x = fmap (\y -> x {_nconCxt = y}) (f (_nconCxt x)) + +nconTypes :: Lens' NCon [Type] +nconTypes f x = fmap (\y -> x {_nconTypes = y}) (f (_nconTypes x)) + +instance HasTypeVars NCon where + typeVarsEx s f (NCon x vars y z) = NCon x vars <$> typeVarsEx s' f y <*> typeVarsEx s' f z + where s' = foldl' (flip Set.insert) s vars + +-- | Normalize a single 'Con' to its constructor name and field types. +normalizeCon :: D.ConstructorInfo -> NCon +normalizeCon info = NCon (D.constructorName info) + (D.tvName <$> D.constructorVars info) + (D.constructorContext info) + (D.constructorFields info) + + +-- | Compute a prism's name by prefixing an underscore for normal +-- constructors and period for operators. +prismName :: Name -> Name +prismName = prismName' False + +prismName' :: Bool -- ^ This is 'True' in the event that: + -- + -- 1. We are generating the name of a classy prism for a + -- data type, and + -- 2. The data type shares a name with one of its + -- constructors (e.g., @data A = A@). + -- + -- In such a scenario, we take care not to generate the same + -- prism name that the constructor receives (e.g., @_A@). + -- For prefix names, we accomplish this by adding an extra + -- underscore; for infix names, an extra dot. + -> Name -> Name +prismName' sameNameAsCon n = + case nameBase n of + [] -> error "prismName: empty name base?" + nb@(x:_) | isUpper x -> mkName (prefix '_' nb) + | otherwise -> mkName (prefix '.' nb) -- operator + where + prefix :: Char -> String -> String + prefix char str | sameNameAsCon = char:char:str + | otherwise = char:str + + +-- | Quantify all the free variables in a type. +close :: Type -> TypeQ +close t = forallT (map plainTVInferred (Set.toList vs)) (cxt[]) (return t) + where + vs = setOf typeVars t + +setOf :: Ord a => Getting (Endo [a]) s a -> s -> Set a +setOf l s = Set.fromList (s ^.. l) + +-- @fromSet@ wasn't always there, and we need compatibility with +-- containers-0.4 to compile on GHC 7.4. +fromSet :: (k -> v) -> Set.Set k -> Map.Map k v +#if MIN_VERSION_containers(0,5,0) +fromSet = Map.fromSet +#else +fromSet f x = Map.fromDistinctAscList [ (k,f k) | k <- Set.toAscList x ] +#endif + +-- | Apply arguments to a type constructor +appsT :: TypeQ -> [TypeQ] -> TypeQ +appsT = foldl appT + +-- | Apply arguments to a function +appsE1 :: ExpQ -> [ExpQ] -> ExpQ +appsE1 = foldl appE + +-- | Construct a tuple type given a list of types. +toTupleT :: [TypeQ] -> TypeQ +toTupleT [x] = x +toTupleT xs = appsT (tupleT (length xs)) xs + +-- | Construct a tuple value given a list of expressions. +toTupleE :: [ExpQ] -> ExpQ +toTupleE [x] = x +toTupleE xs = tupE xs + +-- | Construct a tuple pattern given a list of patterns. +toTupleP :: [PatQ] -> PatQ +toTupleP [x] = x +toTupleP xs = tupP xs + diff --git a/src/Lens/Micro/Pro/Type.hs b/src/Lens/Micro/Pro/Type.hs new file mode 100644 --- /dev/null +++ b/src/Lens/Micro/Pro/Type.hs @@ -0,0 +1,57 @@ +{-| +Module : Lens.Micro.Pro.Type +Copyright : (C) 2013-2016 Edward Kmett, 2018 Monadfix +License : BSD-style (see the file LICENSE) + +This module defines just the 'Iso' and 'Prism' types, in order to break a +dependency cycle. You'll find the interesting stuff in 'Lens.Micro.Pro' and +'Lens.Micro.Pro.Internal'. +-} +module Lens.Micro.Pro.Type + ( Iso, Iso' + , Prism, Prism' + ) + where +-------------------------------------------------------------------------------- +import Data.Profunctor +-------------------------------------------------------------------------------- + +{- | +The type signature of 'Lens.Micro.Pro.iso' provides a nice interpretation of +'Iso'. If you want to apply a function @a -> b@ to a type @s@, you'd have to +convert with @s -> a@, apply your function @a -> b@, and convert back with +@b -> t@. + +@ +'Lens.Micro.Pro.iso' :: (s -> a) -> (b -> t) -> Iso s t a b +-- or, put monomorphically +'Lens.Micro.Pro.iso' :: (s -> a) -> (a -> s) -> Iso' s a +@ +-} + +type Iso s t a b = forall p f. (Profunctor p, Functor f) + => p a (f b) -> p s (f t) + +{- | +The type of monomorphic isomorphisms, i.e. isos that change neither the outer type +@s@ nor the inner type @a@. +-} + +type Iso' s a = Iso s s a a + +{- | +* @s@ is the type of the whole structure +* @t@ is the type of the reconstructed structure +* @a@ is the type of the target +* @b@ is the type of the value used for reconstruction +-} +type Prism s t a b = forall p f. (Choice p, Applicative f) + => p a (f b) -> p s (f t) + +{- | +The type of monomorphic prisms, i.e. prisms that change neither the outer type +@s@ nor the inner type @a@. +-} + +type Prism' s a = Prism s s a a + diff --git a/src/Lens/Micro/ProCompat.hs b/src/Lens/Micro/ProCompat.hs new file mode 100644 --- /dev/null +++ b/src/Lens/Micro/ProCompat.hs @@ -0,0 +1,23 @@ +{- | +Module : Lens.Micro.ProCompat +Copyright : (C) 2013-2016 Edward Kmett, 2018 Monadfix +License : BSD-style (see the file LICENSE) + +This module re-exports "Lens.Micro.Platform", overriding definitions where +necesarry. +-} +module Lens.Micro.ProCompat + ( module Lens.Micro.Platform + , module Lens.Micro.Pro + ) + where +-------------------------------------------------------------------------------- + +-- everything hidden here is redefined in 'Lens.Micro.Pro' +import Lens.Micro.Platform hiding + ( _Left, _Right, _Just, _Nothing, _Show + , strict, lazy, packed, unpacked + , non + ) +import Lens.Micro.Pro +