fclabels 1.1.7.1 → 2.0
raw patch · 16 files changed
+1508/−564 lines, 16 filesdep ~base
Dependency ranges changed: base
Files
- fclabels.cabal +68/−17
- src/Data/Label.hs +83/−39
- src/Data/Label/Abstract.hs +0/−132
- src/Data/Label/Base.hs +117/−0
- src/Data/Label/Derive.hs +530/−152
- src/Data/Label/Failing.hs +93/−0
- src/Data/Label/Maybe.hs +0/−75
- src/Data/Label/MaybeM.hs +0/−31
- src/Data/Label/Monadic.hs +76/−0
- src/Data/Label/Mono.hs +89/−0
- src/Data/Label/Partial.hs +92/−0
- src/Data/Label/Point.hs +186/−0
- src/Data/Label/Poly.hs +112/−0
- src/Data/Label/Pure.hs +0/−46
- src/Data/Label/PureM.hs +0/−72
- src/Data/Label/Total.hs +62/−0
fclabels.cabal view
@@ -1,28 +1,76 @@ Name: fclabels-Version: 1.1.7.1+Version: 2.0 Author: Sebastiaan Visser, Erik Hesselink, Chris Eidhof, Sjoerd Visscher with lots of help and feedback from others.-Synopsis: First class accessor labels.+Synopsis: First class accessor labels implemented as lenses. Description: This package provides first class labels that can act as bidirectional record fields. The labels can be derived automatically using Template Haskell which means you don't have to write any boilerplate yourself. The labels are implemented as- lenses and are fully composable. Labels can be used to /get/,- /set/ and /modify/ parts of a datatype in a consistent way.+ /lenses/ and are fully composable. Lenses can be used to /get/,+ /set/ and /modify/ parts of a data type in a consistent way. .- See "Data.Label" for an introductory explanation.+ See "Data.Label" for an introductory explanation or see the+ introductory blog post at+ <http://fvisser.nl/post/2013/okt/1/fclabels-2.0.html> .- Internally lenses are not tied to Haskell functions directly,- but are implemented as arrows. Arrows allow the lenses to be run- in custom computational contexts. This approach allows us to+ * /Total and partial lenses/+ .+ Internally lenses do not used Haskell functions directly, but+ are implemented as categories. Categories allow the lenses to be+ run in custom computational contexts. This approach allows us to make partial lenses that point to fields of multi-constructor datatypes in an elegant way. .- See the "Data.Label.Maybe" module for the use of partial labels.+ See "Data.Label.Partial" for the use of partial labels. .- > 1.1.6 -> 1.1.7- > - Fixed compilation issue on newer GHC using clang.- > Thanks to Audrey Tang.+ * /Monomorphic and polymorphic lenses/+ .+ We have both polymorphic and monomorphic lenses. Polymorphic+ lenses allow updates that change the type. The types of+ polymorphic lenses are slightly more verbose than their+ monomorphic counterparts, but their usage is similar. Because+ monomorphic lenses are built by restricting the types of+ polymorphic lenses they are essentially the same and can be+ freely composed with eachother.+ .+ See "Data.Label.Mono" and "Data.Label.Poly" for the difference+ between polymorphic and monomorphic lenses.+ .+ * /Using fclabels/+ .+ To simplify working with labels we supply both a set of labels+ for Haskell's base types, like lists, tuples, Maybe and Either,+ and we supply a set of combinators for working with labels for+ values in the Reader and State monad.+ .+ See "Data.Label.Base" and "Data.Label.Monadic" for more+ information.+ .+ * /Changelog from 1.1.7.1 to 2.0/+ .+ > - Introduced polymorphic lenses.+ > - Lenses are now based on getters and modifiers, not getters and setters.+ > - Pure lenses are now named Total lenses.+ > - Maybe lenses are now named Partial lenses.+ > - Introduced Failing lenses that preserve errors.+ > - Generalized Point data type.+ > - Removed unused monadic functions for partial lenses.+ > - Added ArrowFail type class.+ > - Added lenses for base types. (tuples, lists, Maybe, Either)+ > - Isomorphisms now uses regular function space for base morphism.+ > - Swapped iso for more useful inv.+ > - Introduced iso to more easily lift isomorphisms into lenses.+ > - Removed mainly unused bimap.+ > - Added derivation of lenses as expressions.+ > - Convert record declarations directly into fclabels variants.+ > - Allow deriving lenses for GADTs.+ > - Added reasonably sophisticated totality checker for GADT labels.+ > - Derived lenses can now fail in either ArrowZero or ArrowFail.+ > - Alternative instance for Point.+ > - Vertical composition for multi-constructor data types.+ > - Extensive test suite.+ > - Fully documented. Maintainer: Sebastiaan Visser <code@fvisser.nl> Homepage: https://github.com/sebastiaanvisser/fclabels@@ -39,12 +87,15 @@ Exposed-Modules: Data.Label- Data.Label.Abstract+ Data.Label.Base Data.Label.Derive- Data.Label.Maybe- Data.Label.MaybeM- Data.Label.Pure- Data.Label.PureM+ Data.Label.Failing+ Data.Label.Monadic+ Data.Label.Mono+ Data.Label.Partial+ Data.Label.Point+ Data.Label.Poly+ Data.Label.Total GHC-Options: -Wall Build-Depends:
src/Data/Label.hs view
@@ -30,7 +30,6 @@ -- >data Person = Person -- > { _name :: String -- > , _age :: Int--- > , _isMale :: Bool -- > , _place :: Place -- > } deriving Show -- >@@ -54,7 +53,7 @@ Jan, didn't mind using him as an example: >jan :: Person->jan = Person "Jan" 71 True (Place "Utrecht" "The Netherlands" "Europe")+>jan = Person "Jan" 71 (Place "Utrecht" "The Netherlands" "Europe") When we want to be sure Jan is really as old as he claims we can use the `get` function to get the age out as an integer:@@ -71,7 +70,7 @@ And now: >ghci> moveToAmsterdam jan->Person "Jan" 71 True (Place "Amsterdam" "The Netherlands" "Europe")+>Person "Jan" 71 (Place "Amsterdam" "The Netherlands" "Europe") Composition is done using the @(`.`)@ operator which is part of the "Control.Category" module. Make sure to import this module and hide the default@@ -79,7 +78,7 @@ -} --- * Pure lenses.+-- * Total monomorphic lenses. (:->) , lens@@ -87,7 +86,7 @@ , set , modify --- * Views using @Applicative@.+-- * Vertical composition using @Applicative@. {- | @@ -95,21 +94,23 @@ this really takes a while. It will probably take no less than two years before he will actually be settled. To reflect this change it might be useful to have a first class view on the `Person` datatype that only reveals the age and-city. This can be done by using a neat `Applicative` functor instance:+city. This can be done by using a neat `Applicative` functor instance: >import Control.Applicative +>(fstL, sndL) = $(getLabel ''(,))+ >ageAndCity :: Person :-> (Int, String)->ageAndCity = Lens $-> (,) <$> fst `for` age-> <*> snd `for` city . place+>ageAndCity = point $+> (,) <$> fstL >- age+> <*> sndL >- city . place -Because the applicative type class on its own is not very capable of expressing+Because the applicative type class on its own is not capable of expressing bidirectional relations, which we need for our lenses, the actual instance is-defined for an internal helper structure called `Point`. Points are a bit more-general than lenses. As you can see above, the `Lens` constructor has to be-used to convert a `Point` back into a `Lens`. The `for` function must be used-to indicate which partial destructor to use for which lens in the applicative+defined for an internal helper structure called `Point`. Points are a more+general than lenses. As you can see above, the `point` function has to be+used to convert a `Point` back into a `Lens`. The (`>-`) operator is used to+indicate which partial destructor to use per arm of the applicative composition. Now that we have an appropriate age+city view on the `Person` datatype (which@@ -124,43 +125,86 @@ -} -, Lens (Lens)+, point+, (>-) --- * Working with bijections and isomorphisms.--- --- | This package contains a bijection datatype that encodes bidirectional--- functions. Just like lenses, bijections can be composed using the--- "Control.Category" type class. Bijections can be used to change the type of--- a lens. The `Iso` type class, which can be seen as a bidirectional functor,--- can be used to apply bijections to lenses.--- +-- * Working with isomorphisms.+--+-- | This package contains an isomorphisms datatype that encodes bidirectional+-- functions, or better bidirectional categories. Just like lenses,+-- isomorphisms can be composed using the `Category` type class. Isomorphisms+-- can be used to change the type of a lens. Every isomorphism can be lifted+-- into a lens.+-- -- For example, when we want to treat the age of a person as a string we can do -- the following:--- +-- -- > ageAsString :: Person :-> String--- > ageAsString = Bij show read `iso` age+-- > ageAsString = iso (Iso show read) . age -, Bijection (..) , Iso (..)-, for+, inv+, iso -- * Derive labels using Template Haskell. ----- | We can either derive labels with or without type signatures. In the case--- of multi-constructor datatypes some fields might not always be available and--- the derived labels will be partial. Partial labels are provided with an--- additional type context that forces them to be only usable using the--- functions from "Data.Label.Maybe".+-- | Template Haskell functions for automatically generating labels for+-- algebraic datatypes, newtypes and GADTs. There are two basic modes of label+-- generation, the `mkLabels` family of functions create labels (and optionally+-- type signatures) in scope as top level funtions, the `getLabel` family of+-- funtions create labels as expressions that can be named and typed manually.+--+-- In the case of multi-constructor datatypes some fields might not always be+-- available and the derived labels will be partial. Partial labels are+-- provided with an additional type context that forces them to be only usable+-- in the `Partial' or `Failing` context.+--+-- More derivation functions can be found in "Data.Label.Derive". -, mkLabels , mkLabel-, mkLabelsWith-, mkLabelsMono-, mkLabelsNoTypes+, mkLabels+, getLabel+, fclabels ) where -import Data.Label.Abstract (Bijection(..), Iso(..), for, Lens(..))-import Data.Label.Pure-import Data.Label.Derive+import Data.Label.Point (Iso(..), inv)+import Data.Label.Poly (point, (>-))+import Data.Label.Mono (iso, (:->))+import Data.Label.Derive (mkLabel, mkLabels, getLabel, fclabels)++import qualified Data.Label.Mono as Mono++{-# INLINE lens #-}+{-# INLINE get #-}+{-# INLINE modify #-}+{-# INLINE set #-}++-------------------------------------------------------------------------------++-- | Create a total lens from a getter and a modifier.+--+-- We expect the following law to hold:+--+-- > get l (modify l m f) == m (get l f)++lens :: (f -> a) -- ^ Getter.+ -> ((a -> a) -> f -> f) -- ^ Modifier.+ -> f :-> a+lens g s = Mono.lens g (uncurry s)++-- | Get the getter function from a lens.++get :: (f :-> a) -> f -> a+get = Mono.get++-- | Get the modifier function from a lens.++modify :: f :-> a -> (a -> a) -> f -> f+modify = curry . Mono.modify++-- | Get the setter function from a lens.++set :: (f :-> a) -> a -> f -> f+set = curry . Mono.set
− src/Data/Label/Abstract.hs
@@ -1,132 +0,0 @@-{-# LANGUAGE- TypeOperators- , Arrows- , TupleSections- , FlexibleInstances- , MultiParamTypeClasses #-}-module Data.Label.Abstract where--import Control.Arrow-import Prelude hiding ((.), id)-import Control.Applicative-import Control.Category--{-# INLINE _modify #-}-{-# INLINE lens #-}-{-# INLINE get #-}-{-# INLINE set #-}-{-# INLINE modify #-}-{-# INLINE bimap #-}-{-# INLINE for #-}-{-# INLINE liftBij #-}---- | Abstract Point datatype. The getter and setter functions work in some--- arrow.--data Point arr f i o = Point- { _get :: f `arr` o- , _set :: (i, f) `arr` f- }---- | Modification as a compositon of a getter and setter. Unfortunately,--- `ArrowApply' is needed for this composition.--_modify :: ArrowApply arr => Point arr f i o -> (o `arr` i, f) `arr` f-_modify l = proc (m, f) -> do i <- m . _get l -<< f; _set l -< (i, f)---- | Abstract Lens datatype. The getter and setter functions work in some--- arrow. Arrows allow for effectful lenses, for example, lenses that might--- fail or use state.--newtype Lens arr f a = Lens { unLens :: Point arr f a a }---- | Create a lens out of a getter and setter.--lens :: (f `arr` a) -> ((a, f) `arr` f) -> Lens arr f a-lens g s = Lens (Point g s)---- | Get the getter arrow from a lens.--get :: Arrow arr => Lens arr f a -> f `arr` a-get = _get . unLens---- | Get the setter arrow from a lens.--set :: Arrow arr => Lens arr f a -> (a, f) `arr` f-set = _set . unLens---- | Get the modifier arrow from a lens.--modify :: ArrowApply arr => Lens arr f o -> (o `arr` o, f) `arr` f-modify = _modify . unLens--instance ArrowApply arr => Category (Lens arr) where- id = lens id (arr fst)- Lens a . Lens b = lens (_get a . _get b) (_modify b . first (curryA (_set a)))- where curryA f = arr (\i -> f . arr (i,))- {-# INLINE id #-}- {-# INLINE (.) #-}--instance Arrow arr => Functor (Point arr f i) where- fmap f x = Point (arr f . _get x) (_set x)- {-# INLINE fmap #-}--instance Arrow arr => Applicative (Point arr f i) where- pure a = Point (arr (const a)) (arr snd)- a <*> b = Point (arr app . (_get a &&& _get b)) (_set b . (arr fst &&& _set a))- {-# INLINE pure #-}- {-# INLINE (<*>) #-}---- | Make a 'Point' diverge in two directions.--bimap :: Arrow arr => (o' `arr` o) -> (i `arr` i') -> Point arr f i' o' -> Point arr f i o-bimap f g l = Point (f . _get l) (_set l . first g)--infix 8 `for`--for :: Arrow arr => (i `arr` o) -> Lens arr f o -> Point arr f i o-for p = bimap id p . unLens---- | The bijections datatype, an arrow that works in two directions. --infix 8 `Bij`--data Bijection arr a b = Bij { fw :: a `arr` b, bw :: b `arr` a }---- | Bijections as categories.--instance Category arr => Category (Bijection arr) where- id = Bij id id- Bij a b . Bij c d = a . c `Bij` d . b- {-# INLINE id #-}- {-# INLINE (.) #-}---- | Lifting 'Bijection's.--liftBij :: Functor f => Bijection (->) a b -> Bijection (->) (f a) (f b)-liftBij a = fmap (fw a) `Bij` fmap (bw a)---- | The isomorphism type class is like a `Functor' but works in two directions.--infixr 8 `iso`--class Iso arr f where- iso :: Bijection arr a b -> f a `arr` f b---- | Flipped isomorphism.--osi :: Iso arr f => Bijection arr b a -> f a `arr` f b-osi (Bij a b) = iso (Bij b a)---- | We can diverge 'Lens'es using an isomorphism.--instance Arrow arr => Iso arr (Lens arr f) where- iso bi = arr ((\a -> lens (fw bi . _get a) (_set a . first (bw bi))) . unLens)- {-# INLINE iso #-}---- | We can diverge 'Bijection's using an isomorphism.--instance Arrow arr => Iso arr (Bijection arr a) where- iso = arr . (.)- {-# INLINE iso #-}-
+ src/Data/Label/Base.hs view
@@ -0,0 +1,117 @@+{- |+Labels for data types in the base package. The lens types are kept abstract to+be fully reusable in custom contexts. Build to be imported qualified.+-}++{-# LANGUAGE+ NoMonomorphismRestriction+ , TemplateHaskell+ , TypeOperators+ #-}++module Data.Label.Base+(+-- * Lenses for lists.+ head+, tail++-- * Lenses for Either.+, left+, right++-- * Lens for Maybe.+, just++-- * Lenses for 2-tuples.+, fst+, snd+, swap++-- * Lenses for 3-tuples.+, fst3+, snd3+, trd3++-- * Read/Show isomorphism.+, readShow+)+where++import Prelude hiding (fst, snd, head, tail)+import Control.Arrow (arr, Kleisli(..), ArrowApply, ArrowZero, ArrowChoice)+import Data.Maybe (listToMaybe)+import Data.Label.Partial (Partial)+import Data.Label++import qualified Data.Label.Mono as Mono+import qualified Data.Label.Poly as Poly+import qualified Data.Tuple as Tuple++-- | Lens pointing to the head of a list's cons cell. (Partial and monomorphic)++head :: (ArrowZero arr, ArrowApply arr, ArrowChoice arr)+ => Mono.Lens arr [a] a++-- | Lens pointing to the tail of a list's cons cell. (Partial and monomorphic)++tail :: (ArrowZero arr, ArrowApply arr, ArrowChoice arr)+ => Mono.Lens arr [a] [a]++(head, tail) = $(getLabel ''[])++-- | Lens pointing to the left value in an Either. (Partial and polymorphic)++left :: (ArrowZero arr, ArrowApply arr, ArrowChoice arr)+ => Poly.Lens arr (Either a b -> Either o b) (a -> o)++-- | Lens pointing to the right value in an Either. (Partial and polymorphic)++right :: (ArrowZero arr, ArrowApply arr, ArrowChoice arr)+ => Poly.Lens arr (Either a b -> Either a o) (b -> o)++(left, right) = $(getLabel ''Either)++-- | Lens pointing to the value in a Maybe. (Partial and polymorphic)++just :: (ArrowChoice cat, ArrowZero cat, ArrowApply cat)+ => Poly.Lens cat (Maybe a -> Maybe b) (a -> b)++just = $(getLabel ''Maybe)++-- | Lens pointing to the first component of a 2-tuple. (Total and polymorphic)++fst :: ArrowApply arr => Poly.Lens arr ((a, b) -> (o, b)) (a -> o)++-- | Lens pointing to the second component of a 2-tuple. (Total and polymorphic)++snd :: ArrowApply arr => Poly.Lens arr ((a, b) -> (a, o)) (b -> o)++(fst, snd) = $(getLabel ''(,))++-- | Polymorphic lens that swaps the components of a tuple. (Total and polymorphic)++swap :: ArrowApply arr => Poly.Lens arr ((a, b) -> (c, d)) ((b, a) -> (d, c))+swap = let io = Iso (arr Tuple.swap) (arr Tuple.swap) in Poly.iso io io++-- | Lens pointing to the first component of a 3-tuple. (Total and polymorphic)++fst3 :: ArrowApply arr => Poly.Lens arr ((a, b, c) -> (o, b, c)) (a -> o)++-- | Lens pointing to the second component of a 3-tuple. (Total and polymorphic)++snd3 :: ArrowApply arr => Poly.Lens arr ((a, b, c) -> (a, o, c)) (b -> o)++-- | Lens pointing to the third component of a 3-tuple. (Total and polymorphic)++trd3 :: ArrowApply arr => Poly.Lens arr ((a, b, c) -> (a, b, o)) (c -> o)++(fst3, snd3, trd3) = $(getLabel ''(,,))++-- | Partial isomorphism for readable and showable values. Can easily be lifted+-- into a lens by using `iso`.++readShow :: (Read a, Show a) => Iso Partial String a+readShow = Iso r s+ where r = Kleisli (fmap Tuple.fst . listToMaybe . readsPrec 0)+ s = arr show+
src/Data/Label/Derive.hs view
@@ -1,221 +1,599 @@-{-# OPTIONS -fno-warn-orphans #-}+{- |+Template Haskell functions for automatically generating labels for algebraic+datatypes, newtypes and GADTs. There are two basic modes of label generation,+the `mkLabels` family of functions create labels (and optionally type+signatures) in scope as top level funtions, the `getLabel` family of funtions+create labels as expressions that can be named and typed manually.++In the case of multi-constructor datatypes some fields might not always be+available and the derived labels will be partial. Partial labels are provided+with an additional type context that forces them to be only usable in the+`Partial' or `Failing` context.+-}+ {-# LANGUAGE- TemplateHaskell- , OverloadedStrings- , FlexibleContexts- , FlexibleInstances+ DeriveFunctor+ , DeriveFoldable+ , TemplateHaskell , TypeOperators , CPP #-}+ module Data.Label.Derive-( mkLabels-, mkLabel+(++-- * Generate labels in scope.+ mkLabel+, mkLabels+, mkLabelsNamed++-- * Produce labels as expressions.+, getLabel++-- * First class record labels.+, fclabels++-- * Low level derivation functions. , mkLabelsWith-, mkLabelsMono-, mkLabelsNoTypes-, defaultMakeLabel-, gDerive-) where+, getLabelWith+, defaultNaming+)+where +import Control.Applicative import Control.Arrow import Control.Category import Control.Monad-import Data.Char-import Data.Function (on)-import Data.Label.Abstract-import Data.Label.Pure ((:->))-import Data.Label.Maybe ((:~>))-import Data.List+import Data.Char (toLower, toUpper)+import Data.Foldable (Foldable, toList)+import Data.Label.Point+import Data.List (groupBy, sortBy, delete, nub)+import Data.Maybe (fromMaybe) import Data.Ord import Data.String import Language.Haskell.TH-import Language.Haskell.TH.Syntax import Prelude hiding ((.), id) --- Throw a fclabels specific error.+import qualified Data.Label.Mono as Mono+import qualified Data.Label.Poly as Poly -fclError :: String -> a-fclError err = error ("Data.Label.Derive: " ++ err)+-------------------------------------------------------------------------------+-- Publicly exposed functions. --- | Derive lenses including type signatures for all the record selectors for a+-- | Derive labels including type signatures for all the record selectors for a -- collection of datatypes. The types will be polymorphic and can be used in an -- arbitrary context. mkLabels :: [Name] -> Q [Dec]-mkLabels = mkLabelsWith defaultMakeLabel+mkLabels = liftM concat . mapM (mkLabelsWith defaultNaming True False False True) --- | Derive lenses including type signatures for all the record selectors in a+-- | Derive labels including type signatures for all the record selectors in a -- single datatype. The types will be polymorphic and can be used in an -- arbitrary context. mkLabel :: Name -> Q [Dec] mkLabel = mkLabels . return --- | Generate the label name from the record field name.--- For instance, @drop 1 . dropWhile (/='_')@ creates a label @val@ from a--- record @Rec { rec_val :: X }@.--mkLabelsWith :: (String -> String) -> [Name] -> Q [Dec]-mkLabelsWith makeLabel = liftM concat . mapM (derive1 makeLabel True False)---- | Derive lenses including type signatures for all the record selectors in a--- datatype. The signatures will be concrete and can only be used in the--- appropriate context.+-- | Like `mkLabels`, but uses the specified function to produce custom names+-- for the labels.+--+-- For instance, @(drop 1 . dropWhile (/='_'))@ creates a label+-- @val@ from a record @Rec { rec_val :: X }@. -mkLabelsMono :: [Name] -> Q [Dec]-mkLabelsMono = liftM concat . mapM (derive1 defaultMakeLabel True True)+mkLabelsNamed :: (String -> String) -> [Name] -> Q [Dec]+mkLabelsNamed mk = liftM concat . mapM (mkLabelsWith mk True False False True) --- | Derive lenses without type signatures for all the record selectors in a--- datatype.+-- | Derive unnamed labels as n-tuples that can be named manually. The types+-- will be polymorphic and can be used in an arbitrary context.+--+-- Example:+--+-- > (left, right) = $(getLabel ''Either)+--+-- The lenses can now also be typed manually:+--+-- > left :: (Either a b -> Either c b) :~> (a -> c)+-- > right :: (Either a b -> Either a c) :~> (b -> c)+--+-- Note: Because of the abstract nature of the generated lenses and the top+-- level pattern match, it might be required to use 'NoMonomorphismRestriction'+-- in some cases. -mkLabelsNoTypes :: [Name] -> Q [Dec]-mkLabelsNoTypes = liftM concat . mapM (derive1 defaultMakeLabel False False)+getLabel :: Name -> Q Exp+getLabel = getLabelWith True False False --- Helpers to generate all labels for one datatype.+-- | Low level label as expression derivation function. -derive1 :: (String -> String) -> Bool -> Bool -> Name -> Q [Dec]-derive1 makeLabel signatures concrete = reify >=> gDerive makeLabel signatures concrete+getLabelWith+ :: Bool -- ^ Generate type signatures or not.+ -> Bool -- ^ Generate concrete type or abstract type. When true the+ -- signatures will be concrete and can only be used in the+ -- appropriate context. Total labels will use (`:->`) and partial+ -- labels will use either `Lens Partial` or `Lens Failing`+ -- dependent on the following flag:+ -> Bool -- ^ Use `ArrowFail` for failure instead of `ArrowZero`.+ -> Name -- ^ The type to derive labels for.+ -> Q Exp -gDerive :: (String -> String) -> Bool -> Bool -> Info -> Q [Dec]-gDerive makeLabel signatures concrete i =- do let -- Only process data and newtype declarations, filter out all- -- constructors and the type variables.- (tyname, cons, vars) =- case i of- TyConI (DataD _ n vs cs _) -> (n, cs, vs)- TyConI (NewtypeD _ n vs c _) -> (n, [c], vs)- _ -> fclError "Can only derive labels for datatypes and newtypes."+getLabelWith sigs concrete failing name =+ do dec <- reifyDec name+ labels <- generateLabels id concrete failing dec+ let bodies = map (\(LabelExpr _ _ _ b) -> b) labels+ types = map (\(LabelExpr _ _ t _) -> t) labels+ context = head $ map (\(LabelExpr _ c _ _) -> c) labels+ vars = head $ map (\(LabelExpr v _ _ _) -> v) labels+ if sigs+ then tupE bodies `sigE`+ forallT vars context (foldl appT (tupleT (length bodies)) types)+ else tupE bodies - -- We are only interested in lenses of record constructors.- recordOnly = groupByCtor [ (f, n) | RecC n fs <- cons, f <- fs ]+-- | Low level standalone label derivation function. - concat `liftM`- mapM (derive makeLabel signatures concrete tyname vars (length cons))- recordOnly+mkLabelsWith+ :: (String -> String) -- ^ Supply a function to perform custom label naming.+ -> Bool -- ^ Generate type signatures or not.+ -> Bool -- ^ Generate concrete type or abstract type. When+ -- true the signatures will be concrete and can only+ -- be used in the appropriate context. Total labels+ -- will use (`:->`) and partial labels will use+ -- either `Lens Partial` or `Lens Failing` dependent+ -- on the following flag:+ -> Bool -- ^ Use `ArrowFail` for failure instead of `ArrowZero`.+ -> Bool -- ^ Generate inline pragma or not.+ -> Name -- ^ The type to derive labels for.+ -> Q [Dec] - where groupByCtor = map (\xs -> (fst (head xs), map snd xs))- . groupBy ((==) `on` (fst3 . fst))- . sortBy (comparing (fst3 . fst))- where fst3 (a, _, _) = a+mkLabelsWith mk sigs concrete failing inl name =+ do dec <- reifyDec name+ mkLabelsWithForDec mk sigs concrete failing inl dec --- Generate the code for the labels.+-- | Default way of generating a label name from the Haskell record selector+-- name. If the original selector starts with an underscore, remove it and make+-- the next character lowercase. Otherwise, add 'l', and make the next+-- character uppercase. --- | Generate a name for the label. If the original selector starts with an--- underscore, remove it and make the next character lowercase. Otherwise,--- add 'l', and make the next character uppercase.-defaultMakeLabel :: String -> String-defaultMakeLabel field =+defaultNaming :: String -> String+defaultNaming field = case field of '_' : c : rest -> toLower c : rest f : rest -> 'l' : toUpper f : rest n -> fclError ("Cannot derive label for record selector with name: " ++ n) -derive :: (String -> String)- -> Bool -> Bool -> Name -> [TyVarBndr] -> Int- -> (VarStrictType, [Name]) -> Q [Dec]-derive makeLabel signatures concrete tyname vars total ((field, _, fieldtyp), ctors) =- do (sign, body) <-- if length ctors == total- then function derivePureLabel- else function deriveMaybeLabel-- return $- if signatures- then [sign, inline, body]- else [inline, body]+-- | Derive labels for all the record types in the supplied declaration. The+-- record fields don't need an underscore prefix. Multiple data types /+-- newtypes are allowed at once.+--+-- The advantage of this approach is that you don't need to explicitly hide the+-- original record accessors from being exported and they won't show up in the+-- derived `Show` instance.+--+-- Example:+--+-- > fclabels [d|+-- > data Record = Record+-- > { int :: Int+-- > , bool :: Bool+-- > } deriving Show+-- > |]+--+-- > ghci> modify int (+2) (Record 1 False)+-- > Record 3 False +fclabels :: Q [Dec] -> Q [Dec]+fclabels decls =+ do ds <- decls+ ls <- forM (ds >>= labels) (mkLabelsWithForDec id True False False False)+ return (concat ((delabelize <$> ds) : ls)) where - -- Generate an inline declaration for the label.- --- -- Type of InlineSpec removed in TH-2.8.0 (GHC 7.6)+ labels :: Dec -> [Dec]+ labels dec =+ case dec of+ DataD {} -> [dec]+ NewtypeD {} -> [dec]+ _ -> []++ delabelize :: Dec -> Dec+ delabelize dec =+ case dec of+ DataD ctx nm vars cs ns -> DataD ctx nm vars (con <$> cs) ns+ NewtypeD ctx nm vars c ns -> NewtypeD ctx nm vars (con c) ns+ rest -> rest+ where con (RecC n vst) = NormalC n (map (\(_, s, t) -> (s, t)) vst)+ con c = c++-------------------------------------------------------------------------------+-- Intermediate data types.++data Label+ = LabelDecl+ Name -- The label name.+ DecQ -- An INLINE pragma for the label.+ [TyVarBndr] -- The type variables requiring forall.+ CxtQ -- The context.+ TypeQ -- The type.+ ExpQ -- The label body.+ | LabelExpr+ [TyVarBndr] -- The type variables requiring forall.+ CxtQ -- The context.+ TypeQ -- The type.+ ExpQ -- The label body.++data Field c = Field+ (Maybe Name) -- Name of the field, when there is one.+ Bool -- Forced to be mono because of type shared with other fields.+ Type -- Type of the field.+ c -- Occurs in this/these constructors.+ deriving (Eq, Functor, Foldable)++type Subst = [(Type, Type)]++data Context = Context+ Int -- Field index.+ Name -- Constructor name.+ Con -- Constructor.+ deriving (Eq, Show)++data Typing = Typing+ Bool -- Monomorphic type or polymorphic.+ TypeQ -- The lens input type.+ TypeQ -- The lens output type.+ [TyVarBndr] -- All used type variables.++-------------------------------------------------------------------------------++mkLabelsWithForDec :: (String -> String) -> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec]+mkLabelsWithForDec mk sigs concrete failing inl dec =+ do labels <- generateLabels mk concrete failing dec+ decls <- forM labels $ \l ->+ case l of+ LabelExpr {} -> return []+ LabelDecl n i v c t b ->+ do bdy <- pure <$> funD n [clause [] (normalB b) []]+ prg <- if inl then pure <$> i else return []+ typ <- if sigs+ then pure <$> sigD n (forallT v c t)+ else return []+ return (concat [prg, typ, bdy])+ return (concat decls)++-- Generate the labels for all the record fields in the data type.++generateLabels :: (String -> String) -> Bool -> Bool -> Dec -> Q [Label]+generateLabels mk concrete failing dec =++ do -- Only process data and newtype declarations, filter out all+ -- constructors and the type variables.+ let (name, cons, vars) =+ case dec of+ DataD _ n vs cs _ -> (n, cs, vs)+ NewtypeD _ n vs c _ -> (n, [c], vs)+ _ -> fclError "Can only derive labels for datatypes and newtypes."++ -- We are only interested in lenses of record constructors.+ fields = groupFields mk cons++ forM fields $ generateLabel failing concrete name vars cons++groupFields :: (String -> String) -> [Con] -> [Field ([Context], Subst)]+groupFields mk+ = map (rename mk)+ . concatMap (\fs -> let vals = concat (toList <$> fs)+ cons = fst <$> vals+ subst = concat (snd <$> vals)+ in nub (fmap (const (cons, subst)) <$> fs)+ )+ . groupBy eq+ . sortBy (comparing name)+ . concatMap constructorFields+ where name (Field n _ _ _) = n+ eq f g = False `fromMaybe` ((==) <$> name f <*> name g)+ rename f (Field n a b c) =+ Field (mkName . f . nameBase <$> n) a b c++constructorFields :: Con -> [Field (Context, Subst)]+constructorFields con =++ case con of++ NormalC c fs -> one <$> zip [0..] fs+ where one (i, f@(_, ty)) = Field Nothing mono ty (Context i c con, [])+ where fsTys = map (typeVariables . snd) (delete f fs)+ mono = any (\x -> any (elem x) fsTys) (typeVariables ty)++ RecC c fs -> one <$> zip [0..] fs+ where one (i, f@(n, _, ty)) = Field (Just n) mono ty (Context i c con, [])+ where fsTys = map (typeVariables . trd) (delete f fs)+ mono = any (\x -> any (elem x) fsTys) (typeVariables ty)+ trd (_, _, x) = x++ InfixC a c b -> one <$> [(0, a), (1, b)]+ where one (i, (_, ty)) = Field Nothing mono ty (Context i c con, [])+ where fsTys = map (typeVariables . snd) [a, b]+ mono = any (\x -> any (elem x) fsTys) (typeVariables ty)++ ForallC x y v -> setEqs <$> constructorFields v+ where eqs = [ (a, b) | EqualP a b <- y ]+ setEqs (Field a b c d) = Field a b c (first upd . second (eqs ++) $ d)+ upd (Context a b c) = Context a b (ForallC x y c)++prune :: [Context] -> [Con] -> [Con]+prune contexts allCons =+ case contexts of+ (Context _ _ con) : _+ -> filter (unifiableCon con) allCons+ [] -> []++unifiableCon :: Con -> Con -> Bool+unifiableCon a b = and (zipWith unifiable (indices a) (indices b))+ where indices con =+ case con of+ NormalC {} -> []+ RecC {} -> []+ InfixC {} -> []+ ForallC _ x _ -> [ c | EqualP _ c <- x ]++unifiable :: Type -> Type -> Bool+unifiable x y =+ case (x, y) of+ ( VarT _ , _ ) -> True+ ( _ , VarT _ ) -> True+ ( AppT a b , AppT c d ) -> unifiable a c && unifiable b d+ ( SigT t k , SigT s j ) -> unifiable t s && k == j+ ( ForallT _ _ t , ForallT _ _ s ) -> unifiable t s+ ( a , b ) -> a == b++generateLabel+ :: Bool+ -> Bool+ -> Name+ -> [TyVarBndr]+ -> [Con]+ -> Field ([Context], Subst)+ -> Q Label++generateLabel failing concrete datatype dtVars allCons+ field@(Field name forcedMono fieldtype (contexts, subst)) =++ do let total = length contexts == length (prune contexts allCons)++ (Typing mono tyI tyO vars)+ <- computeTypes forcedMono fieldtype datatype dtVars subst++ let cat = varT (mkName "cat")+ failE = if failing+ then [| failArrow |]+ else [| zeroArrow |]+ getT = [| arr $(getter total field) |]+ putT = [| arr $(setter total field) |]+ getP = [| $(failE) ||| id <<< $getT |]+ putP = [| $(failE) ||| id <<< $putT |]+ failP = if failing+ then classP ''ArrowFail [ [t| String |], cat]+ else classP ''ArrowZero [cat]+ ctx = if total+ then cxt [ classP ''ArrowApply [cat] ]+ else cxt [ classP ''ArrowChoice [cat]+ , classP ''ArrowApply [cat]+ , failP+ ]+ body = if total+ then [| Poly.point $ Point $getT (modifier $getT $putT) |]+ else [| Poly.point $ Point $getP (modifier $getP $putP) |]+ cont = if concrete+ then cxt []+ else ctx+ partial = if failing+ then [t| Failing String |]+ else [t| Partial |]+ concTy = if total+ then if mono+ then [t| Mono.Lens Total $tyI $tyO |]+ else [t| Poly.Lens Total $tyI $tyO |]+ else if mono+ then [t| Mono.Lens $partial $tyI $tyO |]+ else [t| Poly.Lens $partial $tyI $tyO |]+ ty = if concrete+ then concTy+ else if mono+ then [t| Mono.Lens $cat $tyI $tyO |]+ else [t| Poly.Lens $cat $tyI $tyO |]++ tvs <- nub . binderFromType <$> ty+ return $+ case name of+ Nothing -> LabelExpr tvs cont ty body+ Just n ->+ #if MIN_VERSION_template_haskell(2,8,0)- inline = PragmaD (InlineP labelName Inline FunLike (FromPhase 0))+ -- Generate an inline declaration for the label.+ -- Type of InlineSpec removed in TH-2.8.0 (GHC 7.6)+ let inline = InlineP n Inline FunLike (FromPhase 0) #else- inline = PragmaD (InlineP labelName (InlineSpec True True (Just (True, 0))))+ let inline = InlineP n (InlineSpec True True (Just (True, 0))) #endif- labelName = mkName (makeLabel (nameBase field))+ in LabelDecl n (return (PragmaD inline)) tvs cont ty body - -- Build a single record label definition for labels that might fail.- deriveMaybeLabel = (if concrete then mono else poly, body)- where- mono = forallT prettyVars (return []) [t| $(inputType) :~> $(return prettyFieldtyp) |]- poly = forallT forallVars (return [])- [t| (ArrowChoice $(arrow), ArrowZero $(arrow))- => Lens $(arrow) $(inputType) $(return prettyFieldtyp) |]- body = [| lens (fromRight . $(getter)) (fromRight . $(setter)) |]- where- getter = [| arr (\ p -> $(caseE [|p|] (cases (bodyG [|p|] ) ++ wild))) |]- setter = [| arr (\(v, p) -> $(caseE [|p|] (cases (bodyS [|p|] [|v|]) ++ wild))) |]- cases b = map (\ctor -> match (recP ctor []) (normalB b) []) ctors- wild = [match wildP (normalB [| Left () |]) []]- bodyS p v = [| Right $( record p field v ) |]- bodyG p = [| Right $( varE field `appE` p ) |]+-- Build a total polymorphic modification function from a getter and setter. - -- Build a single record label definition for labels that cannot fail.- derivePureLabel = (if concrete then mono else poly, body)- where- mono = forallT prettyVars (return []) [t| $(inputType) :-> $(return prettyFieldtyp) |]- poly = forallT forallVars (return [])- [t| Arrow $(arrow) => Lens $(arrow) $(inputType) $(return prettyFieldtyp) |]- body = [| lens $(getter) $(setter) |]- where- getter = [| arr $(varE field) |]- setter = [| arr (\(v, p) -> $(record [| p |] field [| v |])) |]+modifier :: ArrowApply cat => cat f o -> cat (i, f) g -> cat (cat o i, f) g+modifier g m = m . first app . arr (\(n, (f, o)) -> ((n, o), f)) . second (id &&& g)+{-# INLINE modifier #-} - -- Compute the type (including type variables of the record datatype.- inputType = return $ foldr (flip AppT) (ConT tyname) (map tvToVarT (reverse prettyVars))+------------------------------------------------------------------------------- - -- Convert a type variable binder to a regular type variable.- tvToVarT (PlainTV tv ) = VarT tv- tvToVarT (KindedTV tv kind) = SigT (VarT tv) kind+getter :: Bool -> Field ([Context], Subst) -> Q Exp+getter total (Field mn _ _ (cons, _)) =+ do let pt = mkName "f"+ nm = maybe (tupE []) (litE . StringL . nameBase) mn+ wild = if total then [] else [match wildP (normalB [| Left $(nm) |]) []]+ rght = if total then id else appE [| Right |]+ mkCase (Context i _ c) = match pat (normalB (rght var)) []+ where (pat, var) = case1 i c+ lamE [varP pt]+ (caseE (varE pt) (map mkCase cons ++ wild))+ where+ case1 i con =+ case con of+ NormalC c fs -> let s = take (length fs) in (conP c (s pats), var)+ RecC c fs -> let s = take (length fs) in (conP c (s pats), var)+ InfixC _ c _ -> (infixP (pats !! 0) c (pats !! 1), var)+ ForallC _ _ c -> case1 i c+ where fresh = mkName . pure <$> delete 'f' ['a'..'z']+ pats1 = varP <$> fresh+ pats = replicate i wildP ++ [pats1 !! i] ++ repeat wildP+ var = varE (fresh !! i) - -- Prettify type variables.- arrow = varT (mkName "arr")- prettyVars = map prettyTyVar vars- forallVars = PlainTV (mkName "arr") : prettyVars- prettyFieldtyp = prettyType fieldtyp+setter :: Bool -> Field ([Context], Subst) -> Q Exp+setter total (Field mn _ _ (cons, _)) =+ do let pt = mkName "f"+ md = mkName "v"+ nm = maybe (tupE []) (litE . StringL . nameBase) mn+ wild = if total then [] else [match wildP (normalB [| Left $(nm) |]) []]+ rght = if total then id else appE [| Right |]+ mkCase (Context i _ c) = match pat (normalB (rght var)) []+ where (pat, var) = case1 i c+ lamE [tupP [varP md, varP pt]]+ (caseE (varE pt) (map mkCase cons ++ wild))+ where+ case1 i con =+ case con of+ NormalC c fs -> let s = take (length fs) in (conP c (s pats), apps (conE c) (s vars))+ RecC c fs -> let s = take (length fs) in (conP c (s pats), apps (conE c) (s vars))+ InfixC _ c _ -> ( infixP (pats !! 0) c (pats !! 1)+ , infixE (Just (vars !! 0)) (conE c) (Just (vars !! 1))+ )+ ForallC _ _ c -> case1 i c+ where fresh = mkName . pure <$> delete 'f' (delete 'v' ['a'..'z'])+ pats1 = varP <$> fresh+ pats = take i pats1 ++ [wildP] ++ drop (i + 1) pats1+ vars1 = varE <$> fresh+ v = varE (mkName "v")+ vars = take i vars1 ++ [v] ++ drop (i + 1) vars1+ apps f as = foldl appE f as - -- Q style record updating.- record rec fld val = val >>= \v -> recUpdE rec [return (fld, v)]+------------------------------------------------------------------------------- - -- Build a function declaration with both a type signature and body.- function (s, b) = liftM2 (,) - (sigD labelName s)- (funD labelName [ clause [] (normalB b) [] ])+computeTypes :: Bool -> Type -> Name -> [TyVarBndr] -> Subst -> Q Typing+computeTypes forcedMono fieldtype datatype dtVars_ subst = -fromRight :: (ArrowChoice a, ArrowZero a) => a (Either b d) d-fromRight = zeroArrow ||| returnA+ do let fieldVars = typeVariables fieldtype+ tyO = return fieldtype+ dtTypes = substitute subst . typeFromBinder <$> dtVars_+ dtBinders = concatMap binderFromType dtTypes+ varNames = nameFromBinder <$> dtBinders+ usedVars = filter (`elem` fieldVars) varNames+ tyI = return $ foldr (flip AppT) (ConT datatype) (reverse dtTypes)+ pretties = mapTyVarBndr pretty <$> dtBinders+ mono = forcedMono || isMonomorphic fieldtype dtBinders + if mono+ then return $ Typing+ mono+ (prettyType <$> tyI)+ (prettyType <$> tyO)+ (nub pretties)+ else+ do let names = return <$> ['a'..'z']+ used = show . pretty <$> varNames+ free = filter (not . (`elem` used)) names+ subs <- forM (zip usedVars free) (\(a, b) -> (,) a <$> newName b)+ let rename = mapTypeVariables (\a -> a `fromMaybe` lookup a subs)++ return $ Typing+ mono+ (prettyType <$> [t| $tyI -> $(rename <$> tyI) |])+ (prettyType <$> [t| $tyO -> $(rename <$> tyO) |])+ (nub (pretties ++ map (mapTyVarBndr pretty) (PlainTV . snd <$> subs)))++isMonomorphic :: Type -> [TyVarBndr] -> Bool+isMonomorphic field vars =+ let fieldVars = typeVariables field+ varNames = nameFromBinder <$> vars+ usedVars = filter (`elem` fieldVars) varNames+ in null usedVars+ -------------------------------------------------------------------------------+-- Generic helper functions dealing with Template Haskell --- Helper functions to prettify type variables.+typeVariables :: Type -> [Name]+typeVariables = map nameFromBinder . binderFromType -prettyName :: Name -> Name-prettyName tv = mkName (takeWhile (/='_') (show tv))+typeFromBinder :: TyVarBndr -> Type+typeFromBinder (PlainTV tv ) = VarT tv+typeFromBinder (KindedTV tv kind) = SigT (VarT tv) kind -prettyTyVar :: TyVarBndr -> TyVarBndr-prettyTyVar (PlainTV tv ) = PlainTV (prettyName tv)-prettyTyVar (KindedTV tv ki) = KindedTV (prettyName tv) ki+binderFromType :: Type -> [TyVarBndr]+binderFromType = go+ where+ go ty =+ case ty of+ ForallT ts _ _ -> ts+ AppT a b -> go a ++ go b+ SigT t _ -> go t+ VarT n -> [PlainTV n]+ _ -> [] -prettyType :: Type -> Type-prettyType (ForallT xs cx ty) = ForallT (map prettyTyVar xs) (map prettyPred cx) (prettyType ty)-prettyType (VarT nm ) = VarT (prettyName nm)-prettyType (AppT ty tx ) = AppT (prettyType ty) (prettyType tx)-prettyType (SigT ty ki ) = SigT (prettyType ty) ki-prettyType ty = ty+mapTypeVariables :: (Name -> Name) -> Type -> Type+mapTypeVariables f = go+ where+ go ty =+ case ty of+ ForallT ts a b -> ForallT (mapTyVarBndr f <$> ts)+ (mapPred f <$> a) (go b)+ AppT a b -> AppT (go a) (go b)+ SigT t a -> SigT (go t) a+ VarT n -> VarT (f n)+ t -> t -prettyPred :: Pred -> Pred-prettyPred (ClassP nm tys) = ClassP (prettyName nm) (map prettyType tys)-prettyPred (EqualP ty tx ) = EqualP (prettyType ty) (prettyType tx)+mapType :: (Type -> Type) -> Type -> Type+mapType f = go+ where+ go ty =+ case ty of+ ForallT v c t -> f (ForallT v c (go t))+ AppT a b -> f (AppT (go a) (go b))+ SigT t k -> f (SigT (go t) k)+ _ -> f ty --- IsString instances for TH types.+substitute :: Subst -> Type -> Type+substitute env = mapType sub+ where sub v = case lookup v env of+ Nothing -> v+ Just w -> w -instance IsString Exp where- fromString = VarE . mkName+nameFromBinder :: TyVarBndr -> Name+nameFromBinder (PlainTV n ) = n+nameFromBinder (KindedTV n _) = n -instance IsString (Q Pat) where- fromString = varP . mkName+mapPred :: (Name -> Name) -> Pred -> Pred+mapPred f (ClassP n ts) = ClassP (f n) (mapTypeVariables f <$> ts)+mapPred f (EqualP t x ) = EqualP (mapTypeVariables f t) (mapTypeVariables f x) -instance IsString (Q Exp) where- fromString = varE . mkName+mapTyVarBndr :: (Name -> Name) -> TyVarBndr -> TyVarBndr+mapTyVarBndr f (PlainTV n ) = PlainTV (f n)+mapTyVarBndr f (KindedTV n a) = KindedTV (f n) a++-- Prettify a TH name.++pretty :: Name -> Name+pretty tv = mkName (takeWhile (/= '_') (show tv))++-- Prettify a type.++prettyType :: Type -> Type+prettyType = mapTypeVariables pretty++-- Reify a name into a declaration.++reifyDec :: Name -> Q Dec+reifyDec name =+ do info <- reify name+ case info of+ TyConI dec -> return dec+ _ -> fclError "Info must be type declaration type."++-- Throw a fclabels specific error.++fclError :: String -> a+fclError err = error ("Data.Label.Derive: " ++ err)
+ src/Data/Label/Failing.hs view
@@ -0,0 +1,93 @@+{-| Lenses for getters and updates that can potentially fail with some error+value. Like partial lenses, failing lenses are useful for creating accessor+labels for multi constructor data types where projection and modification of+fields will not always succeed. The error value can be used to report what+caused the failure.+-}++{-# LANGUAGE TypeOperators, TupleSections #-}++module Data.Label.Failing+( Lens+, Failing+, lens+, get+, modify+, set+, embed++-- * Seemingly total modifications.+, set'+, modify'+)+where++import Control.Applicative+import Control.Arrow+import Control.Category+import Data.Label.Point (Failing)+import Prelude hiding ((.), id)++import qualified Data.Label.Poly as Poly++{-# INLINE lens #-}+{-# INLINE get #-}+{-# INLINE modify #-}+{-# INLINE set #-}+{-# INLINE embed #-}+{-# INLINE set' #-}+{-# INLINE modify' #-}++-- | Lens type for situations in which the accessor functions can fail with+-- some error information.++type Lens e f o = Poly.Lens (Failing e) f o++-------------------------------------------------------------------------------++-- | Create a lens that can fail from a getter and a modifier that can+-- themselves potentially fail.++lens :: (f -> Either e o) -- ^ Getter.+ -> ((o -> Either e i) -> f -> Either e g) -- ^ Modifier.+ -> Lens e (f -> g) (o -> i)+lens g s = Poly.lens (Kleisli g) (Kleisli (\(m, f) -> s (runKleisli m) f))++-- | Getter for a lens that can fail. When the field to which the lens points+-- is not accessible the getter returns 'Nothing'.++get :: Lens e (f -> g) (o -> i) -> f -> Either e o+get l = runKleisli (Poly.get l)++-- | Modifier for a lens that can fail. When the field to which the lens points+-- is not accessible this function returns 'Left'.++modify :: Lens e (f -> g) (o -> i) -> (o -> i) -> f -> Either e g+modify l m = runKleisli (Poly.modify l . arr (arr m,))++-- | Setter for a lens that can fail. When the field to which the lens points+-- is not accessible this function returns 'Left'.++set :: Lens e (f -> g) (o -> i) -> i -> f -> Either e g+set l v = runKleisli (Poly.set l . arr (v,))++-- | Embed a total lens that points to an `Either` field into a lens that might+-- fail.++embed :: Poly.Lens (->) (f -> g) (Either e o -> Either e i) -> Lens e (f -> g) (o -> i)+embed l = lens (Poly.get l) (\m f -> const (Poly.modify l ((>>= m), f)) <$> Poly.get l f)++-------------------------------------------------------------------------------++-- | Like 'modify' but return behaves like the identity function when the field+-- could not be set.++modify' :: Lens e (f -> f) (o -> o) -> (o -> o) -> f -> f+modify' l m f = either (const f) id (modify l m f)++-- | Like 'set' but return behaves like the identity function when the field+-- could not be set.++set' :: Lens e (f -> f) (o -> o) -> o -> f -> f+set' l v f = either (const f) id (set l v f)+
− src/Data/Label/Maybe.hs
@@ -1,75 +0,0 @@-{-# LANGUAGE TypeOperators, TupleSections #-}-module Data.Label.Maybe-( (:~>)-, lens-, get-, set-, set'-, modify-, modify'-, embed-)-where--import Control.Arrow-import Control.Category-import Control.Monad.Identity-import Control.Monad.Trans.Maybe-import Data.Maybe-import Prelude hiding ((.), id)-import qualified Data.Label.Abstract as A--type MaybeLens f a = A.Lens (Kleisli (MaybeT Identity)) f a---- | Lens type for situations in which the accessor functions can fail. This is--- useful, for example, when accessing fields in datatypes with multiple--- constructors.--type f :~> a = MaybeLens f a--run :: Kleisli (MaybeT Identity) f a -> f -> Maybe a-run l = runIdentity . runMaybeT . runKleisli l---- | Create a lens that can fail from a getter and a setter that can themselves--- potentially fail.--lens :: (f -> Maybe a) -> (a -> f -> Maybe f) -> f :~> a-lens g s = A.lens (kl g) (kl (uncurry s))- where kl a = Kleisli (MaybeT . Identity . a)---- | Getter for a lens that can fail. When the field to which the lens points--- is not accessible the getter returns 'Nothing'.--get :: (f :~> a) -> f -> Maybe a-get l = run (A.get l)---- | Setter for a lens that can fail. When the field to which the lens points--- is not accessible this function returns 'Nothing'.--set :: f :~> a -> a -> f -> Maybe f-set l v = run (A.set l . arr (v,))---- | Like 'set' but return behaves like the identity function when the field--- could not be set.--set' :: (f :~> a) -> a -> f -> f-set' l v f = f `fromMaybe` set l v f---- | Modifier for a lens that can fail. When the field to which the lens points--- is not accessible this function returns 'Nothing'.--modify :: (f :~> a) -> (a -> a) -> f -> Maybe f-modify l m = run (A.modify l . arr (arr m,))---- | Like 'modify' but return behaves like the identity function when the field--- could not be set.--modify' :: (f :~> a) -> (a -> a) -> f -> f-modify' l m f = f `fromMaybe` modify l m f---- | Embed a pure lens that points to a `Maybe` field into a lens that might--- fail.--embed :: A.Lens (->) f (Maybe a) -> f :~> a-embed l = lens (A.get l) (\a f -> Just (A.set l (Just a, f)))-
− src/Data/Label/MaybeM.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module Data.Label.MaybeM-(--- * 'MonadState' lens operations.- gets---- * 'MonadReader' lens operations.-, asks-)-where--import Control.Monad-import Data.Label.Maybe ((:~>))-import qualified Control.Monad.Reader as M-import qualified Control.Monad.State as M-import qualified Data.Label.Maybe as L---- | Get a value out of state, pointed to by the specified lens that might--- fail. When the lens getter fails this computation will fall back to--- `mzero'.--gets :: (M.MonadState f m, MonadPlus m) => (f :~> a) -> m a-gets l = (L.get l `liftM` M.get) >>= (mzero `maybe` return)---- | Fetch a value, pointed to by a lens that might fail, out of a reader--- environment. When the lens getter fails this computation will fall back to--- `mzero'.--asks :: (M.MonadReader f m, MonadPlus m) => (f :~> a) -> m a-asks l = (L.get l `liftM` M.ask) >>= (mzero `maybe` return)-
+ src/Data/Label/Monadic.hs view
@@ -0,0 +1,76 @@+{-| State and Reader operations specialized for working with total lenses. -}++{-# LANGUAGE TypeOperators #-}++module Data.Label.Monadic+(+-- * 'MonadState' lens operations.+ gets+, puts+, modify+, modifyAndGet+, (=:)+, (=.)++-- * 'MonadReader' lens operations.+, asks+, local+)+where++import Control.Monad+import Data.Label.Mono (Lens)++import qualified Data.Label.Total as Total+import qualified Control.Monad.Reader as Reader+import qualified Control.Monad.State as State++-- | Get a value out of the state, pointed to by the specified lens.++gets :: State.MonadState f m => Lens (->) f o -> m o+gets = State.gets . Total.get++-- | Set a value somewhere in the state, pointed to by the specified lens.++puts :: State.MonadState f m => Lens (->) f o -> o -> m ()+puts l = State.modify . Total.set l++-- | Modify a value with a function somewhere in the state, pointed to by the+-- specified lens.++modify :: State.MonadState f m => Lens (->) f o -> (o -> o) -> m ()+modify l = State.modify . Total.modify l++-- | Alias for `puts' that reads like an assignment.++infixr 2 =:+(=:) :: State.MonadState f m => Lens (->) f o -> o -> m ()+(=:) = puts++-- | Alias for `modify' that reads more or less like an assignment.++infixr 2 =.+(=.) :: State.MonadState f m => Lens (->) f o -> (o -> o) -> m ()+(=.) = modify++-- | Fetch a value pointed to by a lens out of a reader environment.++asks :: Reader.MonadReader f m => (Lens (->) f o) -> m o+asks = Reader.asks . Total.get++-- | Execute a computation in a modified environment. The lens is used to+-- point out the part to modify.++local :: Reader.MonadReader f m => (Lens (->) f o) -> (o -> o) -> m a -> m a+local l f = Reader.local (Total.modify l f)++-- | Modify a value with a function somewhere in the state, pointed to by the+-- specified lens. Additionally return a separate value based on the+-- modification.++modifyAndGet :: State.MonadState f m => (Lens (->) f o) -> (o -> (a, o)) -> m a+modifyAndGet l f =+ do (b, a) <- f `liftM` gets l+ puts l a+ return b+
+ src/Data/Label/Mono.hs view
@@ -0,0 +1,89 @@+{- | Lenses that only allow monomorphic updates. Monomorphic lenses are simply+polymorphic lenses with the input and output type variables constraint to the+same type. -}++{-# LANGUAGE+ FlexibleInstances+ , MultiParamTypeClasses+ , TypeOperators+ #-}++module Data.Label.Mono+( Lens+, lens+, get+, modify+, point+, set+, iso++-- * Specialized monomorphic lens operators.+, (:->)+, (:~>)+)+where++import Control.Category+import Control.Arrow+import Data.Label.Point (Point, Iso (..), Total, Partial)+import Prelude hiding ((.), id)++import qualified Data.Label.Poly as Poly++{-# INLINE lens #-}+{-# INLINE get #-}+{-# INLINE modify #-}+{-# INLINE set #-}+{-# INLINE point #-}+{-# INLINE iso #-}++-------------------------------------------------------------------------------++-- | Abstract monomorphic lens datatype. The getter and setter functions work+-- in some category. Categories allow for effectful lenses, for example, lenses+-- that might fail or use state.++type Lens cat f o = Poly.Lens cat (f -> f) (o -> o)++-- | Create a lens out of a getter and setter.++lens :: cat f o -- ^ Getter.+ -> (cat (cat o o, f) f) -- ^ Modifier.+ -> Lens cat f o+lens = Poly.lens++-- | Get the getter arrow from a lens.++get :: Lens cat f o -> cat f o+get = Poly.get++-- | Get the modifier arrow from a lens.++modify :: Lens cat f o -> cat (cat o o, f) f+modify = Poly.modify++-- | Get the setter arrow from a lens.++set :: Arrow arr => Lens arr f o -> arr (o, f) f+set = Poly.set++-- | Create lens from a `Point`.++point :: Point cat f o f o -> Lens cat f o+point = Poly.point++-- | Lift an isomorphism into a `Lens`.++iso :: ArrowApply cat => Iso cat f o -> Lens cat f o+iso (Iso f b) = lens f (app . arr (\(m, v) -> (b . m . f, v)))++-------------------------------------------------------------------------------++-- | Total monomorphic lens.++type f :-> o = Lens Total f o++-- | Partial monomorphic lens.++type f :~> o = Lens Partial f o+
+ src/Data/Label/Partial.hs view
@@ -0,0 +1,92 @@+{-| Monomorphic lenses where the getters and updates can potentially silently+fail. Partial lenses are useful for creating accessor labels for multi+constructor data types where projection and modification of fields will not+always succeed.+-}++{-# LANGUAGE TypeOperators #-}+module Data.Label.Partial+( (:~>)+, Partial+, lens+, get+, modify+, set+, embed++-- * Seemingly total modifications.+, set'+, modify'+)+where++import Control.Applicative+import Control.Arrow+import Control.Category+import Data.Label.Point (Partial)+import Data.Label.Poly (Lens)+import Data.Maybe+import Prelude hiding ((.), id)++import qualified Data.Label.Poly as Poly++{-# INLINE lens #-}+{-# INLINE get #-}+{-# INLINE modify #-}+{-# INLINE set #-}+{-# INLINE embed #-}+{-# INLINE set' #-}+{-# INLINE modify' #-}++-- | Partial lens type for situations in which the accessor functions can fail.++type f :~> o = Lens Partial f o++-------------------------------------------------------------------------------++-- | Create a lens that can fail from a getter and a modifier that can+-- themselves potentially fail.++lens :: (f -> Maybe o) -- ^ Getter.+ -> ((o -> Maybe i) -> f -> Maybe g) -- ^ Modifier.+ -> (f -> g) :~> (o -> i)+lens g s = Poly.lens (Kleisli g) (Kleisli (\(m, f) -> s (runKleisli m) f))++-- | Getter for a lens that can fail. When the field to which the lens points+-- is not accessible the getter returns 'Nothing'.++get :: (f -> g) :~> (o -> i) -> f -> Maybe o+get l = runKleisli (Poly.get l)++-- | Modifier for a lens that can fail. When the field to which the lens points+-- is not accessible this function returns 'Nothing'.++modify :: (f -> g) :~> (o -> i) -> (o -> i) -> f -> Maybe g+modify l m = runKleisli (Poly.modify l . arr ((,) (arr m)))++-- | Setter for a lens that can fail. When the field to which the lens points+-- is not accessible this function returns 'Nothing'.++set :: (f -> g) :~> (o -> i) -> i -> f -> Maybe g+set l v = runKleisli (Poly.set l . arr ((,) v))++-- | Embed a total lens that points to a `Maybe` field into a lens that might+-- fail.++embed :: Lens (->) (f -> g) (Maybe o -> Maybe i) -> (f -> g) :~> (o -> i)+embed l = lens (Poly.get l) (\m f -> const (Poly.modify l ((>>= m), f)) <$> Poly.get l f)++-------------------------------------------------------------------------------++-- | Like 'modify' but return behaves like the identity function when the field+-- could not be set.++modify' :: (f -> f) :~> (o -> o) -> (o -> o) -> f -> f+modify' l m f = f `fromMaybe` modify l m f++-- | Like 'set' but return behaves like the identity function when the field+-- could not be set.++set' :: (f -> f) :~> (o -> o) -> o -> f -> f+set' l v f = f `fromMaybe` set l v f+
+ src/Data/Label/Point.hs view
@@ -0,0 +1,186 @@+{- | The Point data type which generalizes the different lenses and forms the+basis for vertical composition using the `Applicative` type class.+-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE+ TypeOperators+ , Arrows+ , FlexibleInstances+ , MultiParamTypeClasses #-}++module Data.Label.Point+(+-- * The point data type that generalizes lens.+ Point (Point)+, get+, modify+, set+, identity+, compose++-- * Working with isomorphisms.+, Iso (..)+, inv++-- * Specialized lens contexts.+, Total+, Partial+, Failing++-- * Arrow type class for failing with some error.+, ArrowFail (..)+)+where++import Control.Arrow+import Control.Applicative+import Control.Category+import Prelude hiding ((.), id, const, curry, uncurry)++{-# INLINE get #-}+{-# INLINE modify #-}+{-# INLINE set #-}+{-# INLINE identity #-}+{-# INLINE compose #-}+{-# INLINE inv #-}+{-# INLINE const #-}+{-# INLINE curry #-}++-------------------------------------------------------------------------------++-- | Abstract Point datatype. The getter and modifier operations work in some+-- category. The type of the value pointed to might change, thereby changing+-- the type of the outer structure.++data Point cat g i f o = Point (cat f o) (cat (cat o i, f) g)++-- | Get the getter category from a Point.++get :: Point cat g i f o -> cat f o+get (Point g _) = g++-- | Get the modifier category from a Point.++modify :: Point cat g i f o -> cat (cat o i, f) g+modify (Point _ m) = m++-- | Get the setter category from a Point.++set :: Arrow arr => Point arr g i f o -> arr (i, f) g+set p = modify p . first (arr const)++-- | Identity Point. Cannot change the type.++identity :: ArrowApply arr => Point arr f f o o+identity = Point id app++-- | Point composition.++compose :: ArrowApply cat+ => Point cat t i b o+ -> Point cat g t f b+ -> Point cat g i f o+compose (Point f m) (Point g n)+ = Point (f . g) (uncurry (curry n . curry m))++-------------------------------------------------------------------------------++instance Arrow arr => Functor (Point arr f i f) where+ fmap f x = pure f <*> x+ {-# INLINE fmap #-}++instance Arrow arr => Applicative (Point arr f i f) where+ pure a = Point (const a) (arr snd)+ a <*> b = Point (arr app . (get a &&& get b)) $+ proc (t, p) -> do (f, v) <- get a &&& get b -< p+ q <- modify a -< (t . arr ($ v), p)+ modify b -< (t . arr f, q)+ {-# INLINE pure #-}+ {-# INLINE (<*>) #-}++instance Alternative (Point Partial f view f) where+ empty = Point zeroArrow zeroArrow+ Point a b <|> Point c d = Point (a <|> c) (b <|> d)++-------------------------------------------------------------------------------++infix 8 `Iso`++-- | An isomorphism is like a `Category` that works in two directions.++data Iso cat i o = Iso { fw :: cat i o, bw :: cat o i }++-- | Isomorphisms are categories.++instance Category cat => Category (Iso cat) where+ id = Iso id id+ Iso a b . Iso c d = Iso (a . c) (d . b)+ {-# INLINE id #-}+ {-# INLINE (.) #-}++-- | Flip an isomorphism.++inv :: Iso cat i o -> Iso cat o i+inv i = Iso (bw i) (fw i)++-------------------------------------------------------------------------------++-- | Context that represents computations that always produce an output.++type Total = (->)++-- | Context that represents computations that might silently fail.++type Partial = Kleisli Maybe++-- | Context that represents computations that might fail with some error.++type Failing e = Kleisli (Either e)++-- | The ArrowFail class is similar to `ArrowZero`, but additionally embeds+-- some error value in the computation instead of throwing it away.++class Arrow a => ArrowFail e a where+ failArrow :: a e c++instance ArrowFail e Partial where+ failArrow = Kleisli (const Nothing)+ {-# INLINE failArrow #-}++instance ArrowFail e (Failing e) where+ failArrow = Kleisli Left+ {-# INLINE failArrow #-}++-------------------------------------------------------------------------------++-- | Missing Functor instance for Kleisli.++instance Functor f => Functor (Kleisli f i) where+ fmap f (Kleisli m) = Kleisli (fmap f . m)++-- | Missing Applicative instance for Kleisli.++instance Applicative f => Applicative (Kleisli f i) where+ pure a = Kleisli (const (pure a))+ Kleisli a <*> Kleisli b = Kleisli ((<*>) <$> a <*> b)++-- | Missing Alternative instance for Kleisli.++instance Alternative f => Alternative (Kleisli f i) where+ empty = Kleisli (const empty)+ Kleisli a <|> Kleisli b = Kleisli ((<|>) <$> a <*> b)++-------------------------------------------------------------------------------+-- Common operations experessed in a generalized form.++const :: Arrow arr => c -> arr b c+const a = arr (\_ -> a)++curry :: Arrow cat => cat (a, b) c -> (a -> cat b c)+curry m i = m . (const i &&& id)++uncurry :: ArrowApply cat => (a -> cat b c) -> cat (a, b) c+uncurry a = app . arr (first a)+
+ src/Data/Label/Poly.hs view
@@ -0,0 +1,112 @@+{- | Lenses that allow polymorphic updates. -}++{-# LANGUAGE+ FlexibleInstances+ , GADTs+ , MultiParamTypeClasses+ , TypeOperators #-}++module Data.Label.Poly+(++-- * The polymorphic Lens type.+ Lens+, lens+, point+, get+, modify+, set+, iso+, (>-)+)+where++import Control.Category+import Control.Arrow+import Prelude hiding ((.), id)+import Data.Label.Point (Point (Point), Iso(..), identity, compose)++import qualified Data.Label.Point as Point++{-# INLINE lens #-}+{-# INLINE get #-}+{-# INLINE modify #-}+{-# INLINE set #-}+{-# INLINE (>-) #-}+{-# INLINE point #-}+{-# INLINE unpack #-}++-------------------------------------------------------------------------------++-- | Abstract polymorphic lens datatype. The getter and setter functions work+-- in some category. Categories allow for effectful lenses, for example, lenses+-- that might fail or use state.++data Lens cat f o where+ Lens :: !(Point cat g i f o) -> Lens cat (f -> g) (o -> i)+ Id :: ArrowApply cat => Lens cat f f++-- | Create a lens out of a getter and setter.++lens :: cat f o -- ^ Getter.+ -> cat (cat o i, f) g -- ^ Modifier.+ -> Lens cat (f -> g) (o -> i)+lens g m = Lens (Point g m)++-- | Create lens from a `Point`.++point :: Point cat g i f o -> Lens cat (f -> g) (o -> i)+point = Lens++-- | Get the getter arrow from a lens.++get :: Lens cat (f -> g) (o -> i) -> cat f o+get = Point.get . unpack++-- | Get the modifier arrow from a lens.++modify :: Lens cat (f -> g) (o -> i) -> cat (cat o i, f) g+modify = Point.modify . unpack++-- | Get the setter arrow from a lens.++set :: Arrow arr => Lens arr (f -> g) (o -> i) -> arr (i, f) g+set = Point.set . unpack++-- | Lift a polymorphic isomorphism into a `Lens`.+--+-- The isomorphism needs to be passed in twice to properly unify.++iso :: ArrowApply cat => Iso cat f o -> Iso cat g i -> Lens cat (f -> g) (o -> i)+iso (Iso f _) (Iso _ y) = lens f (app . arr (\(m, v) -> (y . m . f, v)))++-------------------------------------------------------------------------------++-- | Category instance for monomorphic lenses.++instance ArrowApply arr => Category (Lens arr) where+ id = Id+ Lens f . Lens g = Lens (compose f g)+ Id . u = u+ u . Id = u+ {-# INLINE id #-}+ {-# INLINE (.) #-}++-- | Make a Lens output diverge by changing the input of the modifier. The+-- operator can be read as /points-to/.++infix 7 >-++(>-) :: Arrow arr => Lens arr (j -> a) (i -> b) -> Lens arr (f -> g) (o -> i) -> Point arr g j f o+(>-) (Lens (Point f _)) (Lens l) = Point (Point.get l) (Point.modify l . first (arr (f .)))+(>-) (Lens (Point f _)) Id = Point id (app . first (arr (f .)))+(>-) Id l = unpack l++-------------------------------------------------------------------------------++-- | Convert a polymorphic lens back to point.++unpack :: Lens cat (f -> g) (o -> i) -> Point cat g i f o+unpack Id = identity+unpack (Lens p) = p+
− src/Data/Label/Pure.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module Data.Label.Pure-( (:->)-, lens-, get-, set-, modify-)-where--import qualified Data.Label.Abstract as A--type PureLens f a = A.Lens (->) f a---- | Pure lens type specialized for pure accessor functions.--type (f :-> a) = PureLens f a---- | Create a pure lens from a getter and a setter.------ We expect the following law to hold:------ > get l (set l a f) == a------ Or, equivalently:------ > set l (get l f) f == f--lens :: (f -> a) -> (a -> f -> f) -> f :-> a-lens g s = A.lens g (uncurry s)---- | Getter for a pure lens.--get :: (f :-> a) -> f -> a-get = A.get---- | Setter for a pure lens.--set :: (f :-> a) -> a -> f -> f-set = curry . A.set---- | Modifier for a pure lens.--modify :: (f :-> a) -> (a -> a) -> f -> f-modify = curry . A.modify-
− src/Data/Label/PureM.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module Data.Label.PureM-(--- * 'MonadState' lens operations.- gets-, puts-, modify-, modifyAndGet-, (=:)-, (=.)---- * 'MonadReader' lens operations.-, asks-, local-)-where--import Control.Monad-import Data.Label.Pure ((:->))-import qualified Control.Monad.Reader as M-import qualified Control.Monad.State as M-import qualified Data.Label.Pure as L---- | Get a value out of the state, pointed to by the specified lens.--gets :: M.MonadState s m => s :-> a -> m a-gets = M.gets . L.get---- | Set a value somewhere in the state, pointed to by the specified lens.--puts :: M.MonadState s m => s :-> a -> a -> m ()-puts l = M.modify . L.set l---- | Modify a value with a function somewhere in the state, pointed to by the--- specified lens.--modify :: M.MonadState s m => s :-> a -> (a -> a) -> m ()-modify l = M.modify . L.modify l---- | Alias for `puts' that reads like an assignment.--infixr 2 =:-(=:) :: M.MonadState s m => s :-> a -> a -> m ()-(=:) = puts---- | Alias for `modify' that reads more or less like an assignment.--infixr 2 =.-(=.) :: M.MonadState s m => s :-> a -> (a -> a) -> m ()-(=.) = modify---- | Fetch a value pointed to by a lens out of a reader environment.--asks :: M.MonadReader r m => (r :-> a) -> m a-asks = M.asks . L.get---- | Execute a computation in a modified environment. The lens is used to--- point out the part to modify.--local :: M.MonadReader r m => (r :-> b) -> (b -> b) -> m a -> m a-local l f = M.local (L.modify l f)---- | Modify a value with a function somewhere in the state, pointed to by the--- specified lens. Additionally return a separate value based on the--- modification.--modifyAndGet :: M.MonadState s m => (s :-> a) -> (a -> (b, a)) -> m b-modifyAndGet l f =- do (b, a) <- f `liftM` gets l- puts l a- return b-
+ src/Data/Label/Total.hs view
@@ -0,0 +1,62 @@+{-| Default lenses for simple total getters and monomorphic updates. Useful for+creating accessor labels for single constructor datatypes. Also useful field+labels that are shared between all the constructors of a multi constructor+datatypes.+-}++{-# LANGUAGE TypeOperators #-}++module Data.Label.Total+( (:->)+, Total+, lens+, get+, modify+, set+)+where++import Data.Label.Poly (Lens)+import Data.Label.Point (Total)++import qualified Data.Label.Poly as Poly++{-# INLINE lens #-}+{-# INLINE get #-}+{-# INLINE modify #-}+{-# INLINE set #-}++-------------------------------------------------------------------------------++-- | Total lens type specialized for total accessor functions.++type f :-> o = Lens Total f o++-- | Create a total lens from a getter and a modifier.+--+-- We expect the following law to hold:+--+-- > get l (set l a f) == a+--+-- > set l (get l f) f == f++lens :: (f -> o) -- ^ Getter.+ -> ((o -> i) -> f -> g) -- ^ Modifier.+ -> (f -> g) :-> (o -> i)+lens g s = Poly.lens g (uncurry s)++-- | Get the getter function from a lens.++get :: ((f -> g) :-> (o -> i)) -> f -> o+get = Poly.get++-- | Get the modifier function from a lens.++modify :: (f -> g) :-> (o -> i) -> (o -> i) -> f -> g+modify = curry . Poly.modify++-- | Get the setter function from a lens.++set :: ((f -> g) :-> (o -> i)) -> i -> f -> g+set = curry . Poly.set+