fclabels 1.1.7.1 → 2.0.5.1
raw patch · 20 files changed
Files
- CHANGELOG +254/−0
- README.md +42/−0
- bench/Benchmark.hs +58/−0
- fclabels.cabal +95/−30
- src/Data/Label.hs +84/−39
- src/Data/Label/Abstract.hs +0/−132
- src/Data/Label/Base.hs +117/−0
- src/Data/Label/Derive.hs +660/−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 +101/−0
- src/Data/Label/Point.hs +167/−0
- src/Data/Label/Poly.hs +121/−0
- src/Data/Label/Pure.hs +0/−46
- src/Data/Label/PureM.hs +0/−72
- src/Data/Label/Total.hs +91/−0
- test/TestSuite.hs +573/−0
+ CHANGELOG view
@@ -0,0 +1,254 @@+CHANGELOG++2.0.5.1+ - Support for GHC 9.0. Thanks to Evan Laforge.++2.0.5+ - Support for GHC 8.10. Thanks to Potato Hatsue.++2.0.4+ - Import Functor, Applicative, and Monad instances for Kleisli from the+ base-orphans package for future GHC 8.10 support.++2.0.3.3++ - Allow GHC 8.4 pre-releases.++2.0.3.2++ - Allow HUnit 1.5.*++2.0.3.1++ - Allow HUnit 1.4.*.+ - Fix test suite on GHC 7.4.++2.0.3++ - Support GHC 8.++2.0.2.3 to 2.0.2.4++ - Allow transformers 0.5.*.++2.0.2.2 to 2.0.2.3++ - Allow HUnit 1.3.*++2.0.2.1 to 2.0.2.2++ - Restored support for GHC 7.4.++2.0.2 to 2.0.2.1++ - Support for GHC 7.10 by widening TH dependencies.++2.0.2+ - Add `for` as a synonym for `>-` to avoid a clash with the Arrows extension.++2.0.1.1++ - Allow mtl 2.2.* and transformers 0.4.*+ - Allow template-haskell 2.9.* in test-suite++2.0.0.5 to 2.0.1++ - Widened TH dependencies.++2.0.0.4 -> 2.0.0.5+ - Add Bug-Reports url again.++2.0.0.3 -> 2.0.0.4+ - Include CHANGELOG in source distribution.++2.0.0.2 -> 2.0.0.3+ - Support GHC 7.0. Note that there seems to be a problem with the+ appicative syntax, see test cases.++2.0.0.1 -> 2.0.0.2+ - Fix deriving with data types with more than 24 fields.++2.0 -> 2.0.0.1+ - Remove warnings on generated labels with OverloadedStrings.++1.1.7.1 -> 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 datatype.+ - 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.++1.1.7 -> 1.1.7.1++ - Removed unicode from cabal file to help messed up build servers.++1.1.6 -> 1.1.7++ - Fixed compilation issue on newer GHC using clang.+ Thanks to 唐鳳.++1.1.5 -> 1.1.6++ - Exposed generic TH derive function.+ Thanks to Bram Schuur.++1.1.4.3 -> 1.1.5++ - Added `modifyAndGet` helper function.+ Thanks to Nikita Volkov.++1.1.4.2 -> 1.1.4.3++ - Make compilable against Template Haskell 2.8.+ Thanks to mgsloan for the pull request.+ - Added TH derivation support for special kinded type variables.++1.1.4 -> 1.1.4.2++ - Make compilable against Template Haskell 2.8.+ Thanks to Shimuuar for the pull request.++1.1.4 -> 1.1.4.1++ - Changed infix type variables to named type variables.+ This makes fclabels compile with GHC > 7.6.+ - Added the `osi` (flipped iso) again.++1.1.3 -> 1.1.4++ - Added function to derive labels for a single datatype.++1.1.1.0 -> 1.1.2++ - Added partial set/modify versions that act as identity when the+ constructor field is not available.++1.1.1.0 -> 1.1.1.1++ - Relax dependency on transformers to include 0.3.0.0.++1.1.0.2 -> 1.1.1.0++ - Added mkLabelsWith function to derive labels with custom names.+ Thanks to Evan Laforge for the patch!++1.1.0.1 -> 1.1.0.2++ - Fixed bug in `id` definition for `Lens (~>)`.+ Thanks to yczhang89 for reporting!++1.1.0 -> 1.1.0.1++ - Relax constraint on Template Haskell for GHC 7.4.++1.0.4 -> 1.1.0++ - Fixed error in derived code in combination with -XMonoLocalBinds.+ - Lowered the priority of =: operator.+ - Added the =. operator for modification in state monads.++1.0.4 -> 1.0.5++ - Relaxed Template Haskell dependency constraint for GHC 7.4+ - Relaxed transformers dependency constraint+ Thanks to Claude Heiland-Allen++1.0.3 -> 1.0.4++ - Bugfix to compile on GHC 6.12 again.++1.0.2 -> 1.0.3++ - Deriving labels for datatypes from other modules now works also when+ imported qualified.++1.0.1 -> 1.0.2++ - Allow generating monomorphic labels.+ - Prettify type variables in TH-derived code.++1.0 -> 1.0.1++ - Some documentation cleanups.+ - Major performance improvements in setting and modifying values by+ inlining most label functions.+ Thanks to Anpheus for benchmarking!++0.11.2 -> 1.0+ - Added abstract arrow based core module.+ - Allow both pure and failing labels to be derived.+ - Major API and documentation cleanup.+ - Renamed lots of exposed function names.++0.11.1.1 -> 0.11.2++ - Relaxed Template Haskell dependency constraint for GHC 7.2+ - Removed redundant import warnings.++0.11.1 -> 0.11.1.1++ - Improved TH support for multiple constructor datatypes.++0.9.1 -> 0.11.0++ - Monadic labels now build against mtl.+ - Separate module for core/non-core code.+ - Code cleanups, especially the TH code.++0.4.2 -> 0.9.1++ - Added askM and localM for running lenses inside MonadReader.+ - Minor documentaion update.+ - Exported Point internals.+ - Renamed Label to Lens.++0.9.1 -> 0.11.0++ - Monadic labels now build against mtl.+ - Separate module for core/non-core code.+ - Code cleanups, especially the TH code.++0.4.2 -> 0.9.1++ - Added askM and localM for running lenses inside MonadReader.+ - Minor documentaion update.+ - Exported Point internals.+ - Renamed Lens to Bijection, which is more correct.+ - Renamed Label to Lens.++0.4.2 -> 0.4.3++ - Added askM and locaM for running labels inside MonadReader.++0.4.2 -> 1.0.0++ - Added askM and localM for running lenses inside MonadReader.+ - Minor documentaion update.+ - Exported Point internals.+ - Renamed Lens to Bijection, which is more correct.+ - Renamed Label to Lens.++0.4.2 -> 0.4.3++ - Added askM and locaM for running labels inside MonadReader.+ - Minor documentaion update.+ - Exported Point internals.+ - Renamed Lens to Bijection, which is more correct.
+ README.md view
@@ -0,0 +1,42 @@+# fclabels: first class accessor labels++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. 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.++### Total and partial lenses++Internally lenses do not use 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 `Data.Label.Partial` for the use of partial labels.++### 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.++On Hackage: http://hackage.haskell.org/package/fclabels++Introduction: http://fvisser.nl/post/2013/okt/1/fclabels-2.0.html+
+ bench/Benchmark.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TemplateHaskell #-}++import Data.Label+import Prelude hiding ((.), id)+import Control.Category+import Criterion.Main++data Person = Person+ { _name :: String+ , _age :: Int+ , _place :: Place+ , _birthplace :: Maybe Place+ } deriving (Show, Eq)++data Place = Place+ { _city+ , _country+ , _continent :: String+ } deriving (Show, Eq)++mkLabels [''Person, ''Place]++jan :: Person+jan = Person "Jan" 71 (Place "Utrecht" "The Netherlands" "Europe") Nothing++getAge :: Int+getAge = get age jan++moveToAmsterdam :: Person -> Person+moveToAmsterdam = set (city . place) "Amsterdam"++moveToAmsterdam' :: Person -> Person+moveToAmsterdam' person = person{_place = (_place person){_city = "Amsterdam"}}++ageByOneYear :: Person -> Person+ageByOneYear = modify age (+1)++ageByOneYear' :: Person -> Person+ageByOneYear' person = person{_age = (+1) $ _age person}++moveAndAge :: Person -> Person+moveAndAge = ageByOneYear . moveToAmsterdam . ageByOneYear . ageByOneYear . ageByOneYear++moveAndAge' :: Person -> Person+moveAndAge' = ageByOneYear' . moveToAmsterdam' . ageByOneYear' . ageByOneYear' . ageByOneYear'++main :: IO ()+main = + defaultMain+ [ bench "warmup" $ whnf show "Hello World"+ , bench "ageByOneYear" $ whnf ageByOneYear jan+ , bench "ageByOneYear'" $ whnf ageByOneYear' jan+ , bench "moveToAmsterdam" $ whnf moveToAmsterdam jan+ , bench "moveToAmsterdam'" $ whnf moveToAmsterdam' jan+ , bench "moveAndAge" $ whnf moveAndAge jan+ , bench "moveAndAge'" $ whnf moveAndAge' jan+ ]+
fclabels.cabal view
@@ -1,59 +1,124 @@ Name: fclabels-Version: 1.1.7.1+Version: 2.0.5.1 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.--Maintainer: Sebastiaan Visser <code@fvisser.nl>-Homepage: https://github.com/sebastiaanvisser/fclabels-Bug-Reports: http://github.com/sebastiaanvisser/fclabels/issues+ * /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 2.0.4 to 2.0.5/+ .+ > - Support for GHC 8.10. Thanks to Potato Hatsue. -License: BSD3-License-File: LICENSE-Category: Data, Lenses-Cabal-Version: >= 1.6-Build-Type: Simple+Maintainer: Sebastiaan Visser <code@fvisser.nl>+Homepage: https://github.com/sebastiaanvisser/fclabels+Bug-Reports: https://github.com/sebastiaanvisser/fclabels/issues+License: BSD3+License-File: LICENSE+Category: Data, Lenses+Cabal-Version: >= 1.10+Build-Type: Simple+Tested-With:+ GHC==7.4.2,+ GHC==7.6.3,+ GHC==7.8.4,+ GHC==7.10.3,+ GHC==8.0.2+Extra-Source-Files:+ README.md+ CHANGELOG Library HS-Source-Dirs: src 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:- base < 5- , template-haskell >= 2.2 && < 2.9- , mtl >= 1.0 && < 2.2- , transformers >= 0.2 && < 0.4+ base >= 4.5 && < 4.16+ , base-orphans >= 0.8.2 && < 0.9+ , template-haskell >= 2.2 && < 2.18+ , mtl >= 1.0 && < 2.3+ , transformers >= 0.2 && < 0.6 + Default-Language: Haskell2010+ Source-Repository head Type: git Location: git://github.com/sebastiaanvisser/fclabels.git +Test-Suite suite+ Type: exitcode-stdio-1.0+ HS-Source-Dirs: test+ Main-Is: TestSuite.hs+ Ghc-Options: -Wall -threaded+ Build-Depends:+ base < 5+ , fclabels+ , template-haskell+ , mtl+ , transformers+ , HUnit >= 1.2 && < 1.7+ Default-Language: Haskell2010++Benchmark benchmark+ Type: exitcode-stdio-1.0+ HS-Source-Dirs: bench+ Main-Is: Benchmark.hs+ Ghc-Options: -Wall -threaded+ Build-Depends:+ base < 5+ , fclabels+ , criterion < 1.6+ Default-Language: Haskell2010
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,87 @@ -} -, Lens (Lens)+, point+, (>-)+, for --- * 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, (>-), for)+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,729 @@-{-# 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)+#if MIN_VERSION_base(4,8,0)+import Data.Foldable (toList)+#else+import Data.Foldable (Foldable, toList)+#endif+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++#if MIN_VERSION_template_haskell(2,17,0)+import Language.Haskell.TH hiding (classP)+#elif MIN_VERSION_template_haskell(2,10,0)+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH hiding (classP, TyVarBndr)+#else+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH hiding (TyVarBndr)+#endif+ 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) --- | Derive lenses including type signatures for all the record selectors for a+#if MIN_VERSION_template_haskell(2,17,0)+#else+data Specificity = SpecifiedSpec -- old versions don't have this+type TyVarBndr a = TH.TyVarBndr+#endif++-------------------------------------------------------------------------------+-- Publicly exposed functions.++-- | 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+ case bodies of+ [b] -> if sigs then b `sigE` forallT vars context (head types) else b+ _ -> 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+-- | 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 - return $- if signatures- then [sign, inline, body]- else [inline, body]+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 + labels :: Dec -> [Dec]+ labels dec =+ case dec of+ DataD {} -> [dec]+ NewtypeD {} -> [dec]+ _ -> []++ delabelize :: Dec -> Dec+ delabelize dec =+ case dec of+#if MIN_VERSION_template_haskell(2,11,0)+ DataD ctx nm vars mk cs ns -> DataD ctx nm vars mk (con <$> cs) ns+ NewtypeD ctx nm vars mk c ns -> NewtypeD ctx nm vars mk (con c) ns+#else+ 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+#endif+ rest -> rest+ where con (RecC n vst) = NormalC n (map (\(_, s, t) -> (s, t)) vst)+#if MIN_VERSION_template_haskell(2,11,0)+ con (RecGadtC ns vst ty) = GadtC ns (map (\(_, s, t) -> (s, t)) vst) ty+#endif+ con c = c++-------------------------------------------------------------------------------+-- Intermediate data types.++data Label+ = LabelDecl+ Name -- The label name.+ DecQ -- An INLINE pragma for the label.+ [TyVarBndr Specificity] -- The type variables requiring forall.+ CxtQ -- The context.+ TypeQ -- The type.+ ExpQ -- The label body.+ | LabelExpr+ [TyVarBndr Specificity] -- 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 Specificity] -- 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+#if MIN_VERSION_template_haskell(2,11,0)+ DataD _ n vs _ cs _ -> (n, cs, vs)+ NewtypeD _ n vs _ c _ -> (n, [c], vs)+#else+ DataD _ n vs cs _ -> (n, cs, vs)+ NewtypeD _ n vs c _ -> (n, [c], vs)+#endif+ _ -> fclError "Can only derive labels for datatypes and newtypes."++ -- We are only interested in lenses of record constructors.+ fields = groupFields mk vars cons++ forM fields $ generateLabel failing concrete name vars cons++groupFields :: (String -> String) -> [TyVarBndr a] -> [Con]+ -> [Field ([Context], Subst)]+groupFields mk vs+ = 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 vs)+ 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 :: [TyVarBndr a] -> Con -> [Field (Context, Subst)]+constructorFields vs 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)++ 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 vs v+#if MIN_VERSION_template_haskell(2,10,0)+ where eqs = [ (a, b) | AppT (AppT EqualityT a) b <- y ]+#else+ where eqs = [ (a, b) | EqualP a b <- y ]+#endif+ 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)+#if MIN_VERSION_template_haskell(2,11,0)+ GadtC cs fs resTy -> concatMap (\c -> one c <$> zip [0..] fs) cs+ where one c (i, f@(_, ty)) = Field Nothing mono ty (Context i c con, mkSubst vs resTy)+ where fsTys = map (typeVariables . snd) (delete f fs)+ mono = any (\x -> any (elem x) fsTys) (typeVariables ty)+ RecGadtC cs fs resTy -> concatMap (\c -> one c <$> zip [0..] fs) cs+ where one c (i, f@(n, _, ty)) = Field (Just n) mono ty (Context i c con, mkSubst vs resTy)+ where fsTys = map (typeVariables . trd) (delete f fs)+ mono = any (\x -> any (elem x) fsTys) (typeVariables ty)++mkSubst :: [TyVarBndr a] -> Type -> Subst+mkSubst vars t = go (reverse vars) t where+ go [] _ = []+ go (v:vs) (AppT t1 t2) = (typeFromBinder v, t2) : go vs t1+ go _ _ = fclError "Non-AppT with type variables in mkSubst. Please report this as a bug for fclabels."+#endif - -- Generate an inline declaration for the label.- --- -- Type of InlineSpec removed in TH-2.8.0 (GHC 7.6)+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 {} -> []+#if MIN_VERSION_template_haskell(2,11,0)+ ForallC _ _ ty -> indices ty+#elif MIN_VERSION_template_haskell(2,10,0)+ ForallC _ x _ -> [ c | AppT (AppT EqualityT _) c <- x ]+#else+ ForallC _ x _ -> [ c | EqualP _ c <- x ]+#endif+#if MIN_VERSION_template_haskell(2,11,0)+ GadtC _ _ ty -> conIndices ty+ RecGadtC _ _ ty -> conIndices ty+ where+ conIndices (AppT (ConT _) ty) = [ty]+ conIndices (AppT rest ty) = conIndices rest ++ [ty]+ conIndices _ = fclError "Non-AppT in conIndices. Please report this as a bug for fclabels."+#endif++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 _)+ <- computeTypes forcedMono fieldtype datatype dtVars subst++ let cat = varT (mkName "cat")+ failE = if failing+ then [| failArrow |]+ else [| zeroArrow |]+ getT = [| arr $(getter failing total field) |]+ putT = [| arr $(setter failing 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 -> Bool -> Field ([Context], Subst) -> Q Exp+getter failing total (Field mn _ _ (cons, _)) =+ do let pt = mkName "f"+ nm = maybe (tupE []) (litE . StringL . nameBase) (guard failing >> mn)+ wild = if total then [] else [match wildP (normalB [| Left $(nm) |]) []]+ rght = if total then id else appE [| Right |]+ mkCase (Context i _ c) = map (\(pat, var) -> match pat (normalB (rght var)) []) (case1 i c)+ lamE [varP pt]+ (caseE (varE pt) (concatMap mkCase cons ++ wild))+ where+ case1 :: Int -> Con -> [(Q Pat, Q Exp)]+ case1 i con =+ case con of+ NormalC c fs -> [one fs c]+ RecC c fs -> [one fs c]+ InfixC _ c _ -> [(infixP (pats !! 0) c (pats !! 1), var)]+ ForallC _ _ c -> case1 i c+#if MIN_VERSION_template_haskell(2,11,0)+ GadtC cs fs _ -> map (one fs) cs+ RecGadtC cs fs _ -> map (one fs) cs+#endif+ where fresh = mkName <$> delete "f" freshNames+ pats1 = varP <$> fresh+ pats = replicate i wildP ++ [pats1 !! i] ++ repeat wildP+ var = varE (fresh !! i)+ one fs c = let s = take (length fs) in (conP c (s pats), var) - -- Prettify type variables.- arrow = varT (mkName "arr")- prettyVars = map prettyTyVar vars- forallVars = PlainTV (mkName "arr") : prettyVars- prettyFieldtyp = prettyType fieldtyp+setter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp+setter failing total (Field mn _ _ (cons, _)) =+ do let pt = mkName "f"+ md = mkName "v"+ nm = maybe (tupE []) (litE . StringL . nameBase) (guard failing >> mn)+ wild = if total then [] else [match wildP (normalB [| Left $(nm) |]) []]+ rght = if total then id else appE [| Right |]+ mkCase (Context i _ c) = map (\(pat, var) -> match pat (normalB (rght var)) []) (case1 i c)+ lamE [tupP [varP md, varP pt]]+ (caseE (varE pt) (concatMap mkCase cons ++ wild))+ where+ case1 i con =+ case con of+ NormalC c fs -> [one fs c]+ RecC c fs -> [one fs c]+ InfixC _ c _ -> [( infixP (pats !! 0) c (pats !! 1)+ , infixE (Just (vars !! 0)) (conE c) (Just (vars !! 1))+ )+ ]+ ForallC _ _ c -> case1 i c+#if MIN_VERSION_template_haskell(2,11,0)+ GadtC cs fs _ -> map (one fs) cs+ RecGadtC cs fs _ -> map (one fs) cs+#endif+ where fresh = mkName <$> delete "f" (delete "v" freshNames)+ 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+ one fs c = let s = take (length fs) in (conP c (s pats), apps (conE c) (s vars)) - -- Q style record updating.- record rec fld val = val >>= \v -> recUpdE rec [return (fld, v)]+freshNames :: [String]+freshNames = map pure ['a'..'z'] ++ map (('a':) . show) [0 :: Integer ..] - -- Build a function declaration with both a type signature and body.- function (s, b) = liftM2 (,) - (sigD labelName s)- (funD labelName [ clause [] (normalB b) [] ])+------------------------------------------------------------------------------- -fromRight :: (ArrowChoice a, ArrowZero a) => a (Either b d) d-fromRight = zeroArrow ||| returnA+computeTypes :: Bool -> Type -> Name -> [TyVarBndr ()] -> Subst -> Q Typing+computeTypes forcedMono fieldtype datatype dtVars_ subst = + 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)+#if MIN_VERSION_template_haskell(2,17,0)+ (flip PlainTV SpecifiedSpec . snd <$> subs)))+#else+ (PlainTV . snd <$> subs)))+#endif++isMonomorphic :: Type -> [TyVarBndr Specificity] -> 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 a -> Type+#if MIN_VERSION_template_haskell(2,17,0)+typeFromBinder (PlainTV tv _) = VarT tv+#else+typeFromBinder (PlainTV tv ) = VarT tv+#endif -prettyTyVar :: TyVarBndr -> TyVarBndr-prettyTyVar (PlainTV tv ) = PlainTV (prettyName tv)-prettyTyVar (KindedTV tv ki) = KindedTV (prettyName tv) ki+#if MIN_VERSION_template_haskell(2,17,0)+typeFromBinder (KindedTV tv _ StarT) = VarT tv+typeFromBinder (KindedTV tv _ kind) = SigT (VarT tv) kind+#elif MIN_VERSION_template_haskell(2,8,0)+typeFromBinder (KindedTV tv StarT) = VarT tv+typeFromBinder (KindedTV tv kind) = SigT (VarT tv) kind+#else+typeFromBinder (KindedTV tv StarK) = VarT tv+typeFromBinder (KindedTV tv kind) = SigT (VarT tv) kind+#endif +binderFromType :: Type -> [TyVarBndr Specificity]+binderFromType = go+ where+ go ty =+ case ty of+ ForallT ts _ _ -> ts+ AppT a b -> go a ++ go b+ SigT t _ -> go t+#if MIN_VERSION_template_haskell(2,17,0)+ VarT n -> [PlainTV n SpecifiedSpec]+#else+ VarT n -> [PlainTV n]+#endif+ _ -> []++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++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++substitute :: Subst -> Type -> Type+substitute env = mapType sub+ where sub v = case lookup v env of+ Nothing -> v+ Just w -> w++nameFromBinder :: TyVarBndr Specificity -> Name+#if MIN_VERSION_template_haskell(2,17,0)+nameFromBinder (PlainTV n _) = n+nameFromBinder (KindedTV n _ _) = n+#else+nameFromBinder (PlainTV n ) = n+nameFromBinder (KindedTV n _) = n+#endif++mapPred :: (Name -> Name) -> Pred -> Pred+#if MIN_VERSION_template_haskell(2,10,0)+mapPred = mapTypeVariables+#else+mapPred f (ClassP n ts) = ClassP (f n) (mapTypeVariables f <$> ts)+mapPred f (EqualP t x ) = EqualP (mapTypeVariables f t) (mapTypeVariables f x)+#endif++mapTyVarBndr :: (Name -> Name) -> TyVarBndr Specificity+ -> TyVarBndr Specificity+#if MIN_VERSION_template_haskell(2,17,0)+mapTyVarBndr f (PlainTV n flag) = PlainTV (f n) flag+mapTyVarBndr f (KindedTV n a flag) = KindedTV (f n) a flag+#else+mapTyVarBndr f (PlainTV n) = PlainTV (f n)+mapTyVarBndr f (KindedTV n a) = KindedTV (f n) a+#endif++-- Prettify a TH name.++pretty :: Name -> Name+pretty tv = mkName (takeWhile (/= '_') (show tv))++-- Prettify a type.+ 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+prettyType = mapTypeVariables pretty -prettyPred :: Pred -> Pred-prettyPred (ClassP nm tys) = ClassP (prettyName nm) (map prettyType tys)-prettyPred (EqualP ty tx ) = EqualP (prettyType ty) (prettyType tx)+-- Reify a name into a declaration. --- IsString instances for TH types.+reifyDec :: Name -> Q Dec+reifyDec name =+ do info <- reify name+ case info of+ TyConI dec -> return dec+ _ -> fclError "Info must be type declaration type." -instance IsString Exp where- fromString = VarE . mkName+-- Throw a fclabels specific error. -instance IsString (Q Pat) where- fromString = varP . mkName+fclError :: String -> a+fclError err = error ("Data.Label.Derive: " ++ err) -instance IsString (Q Exp) where- fromString = varE . mkName+#if MIN_VERSION_template_haskell(2,10,0)+classP :: Name -> [Q Type] -> Q Pred+classP cla tys+ = do tysl <- sequence tys+ return (foldl AppT (ConT cla) tysl)+#endif +trd :: (a, b, c) -> c+trd (_, _, x) = x
+ 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 ()++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,101 @@+{-| 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'++-- * Potentially removing modification.+, update+)+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++-- | Like `modify`, but update allows, depending on the underlying lens, to+-- remove items by modifying to `Nothing`.++update :: (f -> b) :~> (o -> i) -> (o -> Maybe i) -> f -> Maybe b+update l m = runKleisli (Poly.modify l . arr ((,) (Kleisli m)))+
+ src/Data/Label/Point.hs view
@@ -0,0 +1,167 @@+{- | The Point data type which generalizes the different lenses and forms the+basis for vertical composition using the `Applicative` type class.+-}++{-# LANGUAGE+ TypeOperators+ , Arrows+ , FlexibleInstances+ , MultiParamTypeClasses+ , TypeSynonymInstances #-}++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 Data.Orphans ()+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 #-}++-------------------------------------------------------------------------------+-- 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,121 @@+{- | 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+, (>-)+, for+)+where++import Control.Category+import Control.Arrow+import Prelude ()+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++-- | Non-operator version of `>-`, since it clashes with an operator+-- when the Arrows language extension is used.++infix 7 `for`++for :: Arrow arr => Lens arr (j -> a) (i -> b) -> Lens arr (f -> g) (o -> i) -> Point arr g j f o+for = (>-)++-------------------------------------------------------------------------------++-- | 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,91 @@+{-| Default lenses for simple total getters and total possibly polymorphic,+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 CPP, TypeOperators #-}++module Data.Label.Total+( (:->)+, Total+, lens+, get+, modify+, set++-- * Working in contexts.+, traverse+, lifted+)+where++#if MIN_VERSION_base(4,8,0)+import Prelude hiding (traverse)+#endif+import Control.Monad ((<=<), liftM)+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++-- | Modify in some context.++traverse :: Functor m => (f -> g) :-> (o -> i) -> (o -> m i) -> f -> m g+traverse l m f = (\w -> set l w f) `fmap` m (get l f)+++-- | Lifted lens composition.+--+-- For example, useful when specialized to lists:+--+-- > :: (f :-> [o])+-- > -> (o :-> [a])+-- > -> (f :-> [a])++lifted+ :: Monad m+ => (f -> g) :-> (m o -> m i)+ -> (o -> i) :-> (m a -> m b)+ -> (f -> g) :-> (m a -> m b)+lifted a b = lens (get b <=< get a) (modify a . liftM . modify b)+
+ test/TestSuite.hs view
@@ -0,0 +1,573 @@+{- OPTIONS -ddump-splices #-}++{-# LANGUAGE+ NoMonomorphismRestriction+ , KindSignatures+ , GADTs+ , TemplateHaskell+ , TypeOperators+ , RankNTypes+ , FlexibleContexts+ , StandaloneDeriving+ , CPP #-}++-- Needed for the Either String orphan instances.+#if MIN_VERSION_transformers(0,5,0) && MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -Wno-orphans -Wno-warnings-deprecations #-}+#endif++module Main where++import Control.Arrow+import Control.Applicative+import Control.Category+#if MIN_VERSION_transformers(0,5,0) && MIN_VERSION_base(4,9,0)+import Control.Monad (MonadPlus (..))+import Control.Monad.Trans.Error (Error (noMsg))+#endif+import Prelude hiding ((.), id)+import Test.HUnit+import Data.Label+import Data.Label.Derive (defaultNaming, mkLabelsWith)+import Data.Label.Mono ((:~>))+import Data.Label.Failing (Failing)+import Data.Tuple (swap)++import Control.Monad.Reader (runReader)+import Control.Monad.State (evalState, execState, runState)++import qualified Data.Label.Base as L+import qualified Data.Label.Failing as Failing+import qualified Data.Label.Mono as Mono+import qualified Data.Label.Partial as Partial+import qualified Data.Label.Poly as Poly+import qualified Data.Label.Total as Total+import qualified Data.Label.Monadic as Monadic++-------------------------------------------------------------------------------++data NoRecord = NoRecord Integer Bool+ deriving (Eq, Ord, Show)++mkLabel ''NoRecord++fclabels [d|+ newtype Newtype a = Newtype { unNewtype :: [a] }+ |]++deriving instance Eq a => Eq (Newtype a)+deriving instance Ord a => Ord (Newtype a)+deriving instance Show a => Show (Newtype a)++newtypeL :: ArrowApply cat => Poly.Lens cat (Newtype a -> Newtype b) ([a] -> [b])+newtypeL = unNewtype++data Record = Record+ { _fA :: Integer+ , _fB :: Maybe (Newtype Bool)+ , _fC :: Newtype Bool+ , _fD :: Either Integer Bool+ } deriving (Eq, Ord, Show)++mkLabelsWith defaultNaming False False False False ''Record++fD :: ArrowApply cat => Mono.Lens cat (Record) (Either Integer Bool)+fC :: ArrowApply cat => Mono.Lens cat (Record) (Newtype Bool)+fB :: ArrowApply cat => Mono.Lens cat (Record) (Maybe (Newtype Bool))+fA :: ArrowApply cat => Mono.Lens cat (Record) (Integer)++data Multi+ = First { _mA :: Record+ , _mB :: Double+ , _mC :: Either String Float+ }+ | Second { _mB :: Double }+ deriving (Eq, Ord, Show)++mkLabels [''Multi]++data View = View+ { _vA :: Maybe (Newtype Bool)+ , _vB :: Either Integer Bool+ , _vC :: Newtype Bool+ } deriving (Eq, Ord, Show)++mkLabelsWith defaultNaming True True False False ''View++data Direction i a b c d+ = North { _dir :: i, _north :: a }+ | East { _dir :: i, _east :: b }+ | South { _dir :: i, _south :: c }+ | West { _dir :: i, _west :: d }+ | All { _dir :: i, _allDirs :: (a, b, c, d) }+ deriving (Eq, Ord, Show)++mkLabelsWith defaultNaming True False True True ''Direction++-- Higher kinded type variable, requires KindSignatures.++data Fa f a = Fa { fa :: f a }++mkLabel ''Fa++-------------------------------------------------------------------------------++data Gadt a where+ C1 :: { ga :: Integer, gb :: Bool } -> Gadt (Int, Bool)+ C2 :: { gc :: Integer, gd :: Maybe Bool } -> Gadt Bool+ C3 :: { ge :: a, gf :: b } -> Gadt (a, b)+ C4 :: { gg :: a } -> Gadt [a]+ C5 :: { gd :: Maybe Bool } -> Gadt Bool+ C6 :: { gh :: [a] } -> Gadt (a, a, a)++mkLabel ''Gadt++_Ga :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Mono.Lens cat (Gadt (Int, Bool)) Integer+_Gb :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Mono.Lens cat (Gadt (Int, Bool)) Bool+_Gc :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Mono.Lens cat (Gadt Bool) Integer+_Gd :: (ArrowApply cat ) => Mono.Lens cat (Gadt Bool) (Maybe Bool)+_Ge :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt (a, b) -> Gadt (c, b)) (a -> c)+_Gf :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt (a, b) -> Gadt (a, c)) (b -> c)+_Gg :: (ArrowApply cat ) => Poly.Lens cat (Gadt [a] -> Gadt [b]) (a -> b)+_Gh :: (ArrowApply cat ) => Poly.Lens cat (Gadt (a, a, a) -> Gadt (b, b, b)) ([a] -> [b])++_Ga = lGa; _Gb = lGb; _Gc = lGc; _Gd = lGd; _Ge = lGe; _Gf = lGf; _Gg = lGg; _Gh = lGh;++data Gadt2 a b where+ C7, C8 :: { gi :: b, gj :: a } -> Gadt2 a b++mkLabel ''Gadt2++_Gi :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt2 a b -> Gadt2 a c) (b -> c)+_Gj :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt2 a b -> Gadt2 c b) (a -> c)++_Gi = lGi; _Gj = lGj;++-------------------------------------------------------------------------------++-- These instance are needed for the `Failing.Lens String` instance,+-- since that needs a `MonadZero` constraint on `Kleisli (Either String)`,+-- which in turn needs a `MonadPlus (Either String)` constraint.+-- These instances used to exist in transformers but were removed in+-- 0.5.0.0 accidentally, and added in 0.5.2.0. We can probably remove+-- this ifdef after GHC 8 rc3 is released, which will include+-- transformers-0.5.2.0.++#if MIN_VERSION_transformers(0,5,0) && !MIN_VERSION_transformers(0,5,2) && MIN_VERSION_base(4,9,0)+instance (Error e) => Alternative (Either e) where+ empty = Left noMsg+ Left _ <|> n = n+ m <|> _ = m++instance Error e => MonadPlus (Either e) where+ mzero = Left noMsg+ Left _ `mplus` n = n+ m `mplus` _ = m+#endif++-------------------------------------------------------------------------------++embed_fB :: Record :~> Newtype Bool+embed_fB = Partial.embed fB++manual_fA :: Record :-> Integer+manual_fA = Total.lens _fA (\m f -> f { _fA = m (_fA f) })++manual_fA_m :: Mono.Lens (->) Record Integer+manual_fA_m = lens _fA (\m f -> f { _fA = m (_fA f) })++manual_mA :: Multi :~> Record+manual_mA = Partial.lens+ (\p -> case p of First {} -> Just (_mA p); _ -> Nothing)+ (\m p -> case p of First {} -> (\v -> p { _mA = v }) `fmap` m (_mA p); _ -> Nothing)++mA_f :: Failing.Lens String (Multi -> Multi) (Record -> Record)+mA_f = mA++manual_mA_f :: Failing.Lens String (Multi -> Multi) (Record -> Record)+manual_mA_f = Failing.lens+ (\p -> case p of First {} -> Right (_mA p); _ -> Left "mA")+ (\m p -> case p of First {} -> (\v -> p { _mA = v }) `fmap` m (_mA p); _ -> Left "mA")++embed_fD :: Failing.Lens Integer (Record -> Record) (Bool -> Bool)+embed_fD = Failing.embed fD++manual_dir :: Poly.Lens (->) (Direction i a b c d -> Direction e a b c d) (i -> e)+manual_dir = Poly.lens _dir (\(m, f) -> f {_dir = m (_dir f) })++north_f :: Poly.Lens (Failing String) (Direction i a b c d -> Direction i e b c d) (a -> e)+north_f = north++fAmA :: Multi :~> Integer+fAmA = fA . mA++recordView :: Record :-> View+recordView = Poly.point $+ View <$> vA >- fB+ <*> vB >- fD+ <*> vC >- fC++newtypeId :: Newtype Bool :-> Newtype Bool+newtypeId = Poly.point (id <$> id >- id)++-------------------------------------------------------------------------------++fclabels [d|++ data View2 a+ = Con1 { field1 :: Bool+ , field2 :: (a, a)+ }+ | Con2 { field1 :: Bool+ , field3 :: [a]+ }++ |]++deriving instance Eq a => Eq (View2 a)+deriving instance Show a => Show (View2 a)++view :: View2 a :~> Either (Bool, (a, a)) (Bool, [a])+view = point $+ Left <$> L.left >- con1+ <|> Right <$> L.right >- con2+ where con1 = point $+ (,) <$> L.fst >- field1+ <*> L.snd >- field2+ con2 = point $+ (,) <$> L.fst >- field1+ <*> L.snd >- field3++-------------------------------------------------------------------------------+-- Test data type with large number (> 26) of fields.++fclabels [d|++ data C = C { c_a :: (), c_b :: (), c_c :: (), c_d :: (), c_e :: (), c_f :: ()+ , c_g :: (), c_h :: (), c_i :: (), c_j :: (), c_k :: (), c_l :: ()+ , c_m :: (), c_n :: (), c_o :: (), c_p :: (), c_q :: (), c_r :: ()+ , c_s :: (), c_t :: (), c_u :: (), c_v :: (), c_w :: (), c_x :: ()+ , c_y :: (), c_z :: (), c_a0 :: (), c_b0 :: (), c_c0 :: (), c_d0 :: ()+ }++ |]++-------------------------------------------------------------------------------++newtype0, newtype1, newtype2 :: Newtype Bool+newtype0 = Newtype []+newtype1 = Newtype [True]+newtype2 = Newtype [False]++record0, record1, record2, record3, record4, record5, record10, record11 :: Record+record0 = Record 0 Nothing newtype0 (Left 1)+record1 = Record 1 Nothing newtype0 (Left 1)+record2 = Record 0 (Just newtype1) newtype0 (Left 1)+record3 = Record 0 (Just newtype0) newtype0 (Left 1)+record4 = Record 0 Nothing newtype0 (Right True)+record5 = Record 0 Nothing newtype0 (Right False)+record10 = Record 10 Nothing newtype0 (Left 1)+record11 = Record 11 Nothing newtype0 (Left 1)++first0, first1, first2 :: Multi+first0 = First record0 0.0 (Right 1.0)+first1 = First record0 1.0 (Right 1.0)+first2 = First record1 0.0 (Right 1.0)++second0, second1 :: Multi+second0 = Second 0.0+second1 = Second 1.0++north0 :: Direction Integer () () () ()+north0 = North 0 ()++north1 :: Direction Bool () () () ()+north1 = North False ()++north2 :: Direction Integer Bool () () ()+north2 = North 0 False++west0 :: Direction Integer () () () ()+west0 = West 0 ()++mulDiv :: Iso (->) Integer Double+mulDiv = Iso (\i -> fromInteger i / 10) (\i -> round (i * 10))++addSub :: Iso (->) Double Integer+addSub = Iso (\i -> round (i + 10)) (\i -> fromInteger i - 10)++-------------------------------------------------------------------------------++main :: IO ()+main =+ do _ <- runTestTT allTests+ return ()++allTests :: Test+allTests = TestList+ [ mono+ , totalMono+ , partialMono+ , failingMono+ , totalPoly+ , partialPoly+ , failingPoly+ , composition+ , applicativeTotal+ , applicativePartial+ , bijections+ , monadic+ , base+ ]++mono :: Test+mono = TestList+ [ eq "get manual_fA_m" (get manual_fA_m record0) 0+ , eq "set manual_fA_m" (set manual_fA_m 1 record0) record1+ , eq "mod manual_fA_m" (modify manual_fA_m (+ 1) record0) record1+ ] where eq :: (Eq a, Show a) => String -> a -> a -> Test+ eq x = equality ("total mono " ++ x)++totalMono :: Test+totalMono = TestList+ [ eq "get fA" (Total.get fA record0) 0+ , eq "set fA" (Total.set fA 1 record0) record1+ , eq "mod fA" (Total.modify fA (+ 1) record0) record1+ , eq "get manual_fA" (Total.get manual_fA record0) 0+ , eq "set manual_fA" (Total.set manual_fA 1 record0) record1+ , eq "mod manual_fA" (Total.modify manual_fA (+ 1) record0) record1+ , eq "get mB" (Total.get mB first0) 0+ , eq "set mB" (Total.set mB 1 first0) first1+ , eq "mod mB" (Total.modify mB (+ 1) first0) first1+ ] where eq :: (Eq a, Show a) => String -> a -> a -> Test+ eq x = equality ("total mono " ++ x)++partialMono :: Test+partialMono = TestList+ [ eq0 "get mA" (Partial.get mA first0) (Just record0)+ , eq0 "set mA" (Partial.set mA record1 first0) (Just first2)+ , eq0 "mod mA" (Partial.modify mA (Total.modify fA (+ 1)) first0) (Just first2)+ , eq0 "get manual_mA" (Partial.get manual_mA first0) (Just record0)+ , eq0 "set manual_mA" (Partial.set manual_mA record1 first0) (Just first2)+ , eq0 "mod manual_mA" (Partial.modify manual_mA (Total.modify fA (+ 1)) first0) (Just first2)+ , eq1 "get mA" (Partial.get mA second0) Nothing+ , eq1 "set mA" (Partial.set mA record1 second0) Nothing+ , eq1 "mod mA" (Partial.modify mA (Total.modify fA (+ 1)) second0) Nothing+ , eq1 "get manual_mA" (Partial.get manual_mA second0) Nothing+ , eq1 "set manual_mA" (Partial.set manual_mA record1 second0) Nothing+ , eq1 "mod manual_mA" (Partial.modify manual_mA (Total.modify fA (+ 1)) second0) Nothing+ , eq2 "set mA" (Partial.set' mA record1 first0) first2+ , eq2 "mod mA" (Partial.modify' mA (Total.modify fA (+ 1)) first0) first2+ , eq2 "set manual_mA" (Partial.set' manual_mA record1 first0) first2+ , eq2 "mod manual_mA" (Partial.modify' manual_mA (Total.modify fA (+ 1)) first0) first2+ , eq2 "set mA" (Partial.set' mA record1 second0) second0+ , eq2 "mod mA" (Partial.modify' mA (Total.modify fA (+ 1)) second0) second0+ , eq2 "set manual_mA" (Partial.set' manual_mA record1 second0) second0+ , eq2 "mod manual_mA" (Partial.modify' manual_mA (Total.modify fA (+ 1)) second0) second0+ , eq3 "get embed_fB" (Partial.get embed_fB record2) (Just newtype1)+ , eq3 "set embed_fB" (Partial.set embed_fB newtype0 record2) (Just record3)+ , eq3 "mod embed_fB" (Partial.modify embed_fB (const newtype0) record2) (Just record3)+ , eq4 "get embed_fB" (Partial.get embed_fB record0) Nothing+ , eq4 "set embed_fB" (Partial.set embed_fB newtype0 record0) Nothing+ , eq4 "mod embed_fB" (Partial.modify embed_fB (const newtype0) record0) Nothing+ ] where eq0, eq1, eq2, eq3, eq4 :: (Eq a, Show a) => String -> a -> a -> Test+ eq0 x = equality ("partial mono " ++ x)+ eq1 x = equality ("partial mono fail " ++ x)+ eq2 x = equality ("partial mono prime " ++ x)+ eq3 x = equality ("partial mono embed " ++ x)+ eq4 x = equality ("partial mono embed fail" ++ x)++failingMono :: Test+failingMono = TestList+ [ eq0 "get mA_f" (Failing.get mA_f first0) (Right record0)+ , eq0 "set mA_f" (Failing.set mA_f record1 first0) (Right first2)+ , eq0 "mod mA_f" (Failing.modify mA_f (Total.modify fA (+ 1)) first0) (Right first2)+ , eq0 "get manual_mA_f" (Failing.get manual_mA_f first0) (Right record0)+ , eq0 "set manual_mA_f" (Failing.set manual_mA_f record1 first0) (Right first2)+ , eq0 "mod manual_mA_f" (Failing.modify manual_mA_f (Total.modify fA (+ 1)) first0) (Right first2)+ , eq1 "get mA_f fail" (Failing.get mA_f second0) (Left "")+ , eq1 "set mA_f fail" (Failing.set mA_f record1 second0) (Left "")+ , eq1 "mod mA_f fail" (Failing.modify mA_f (Total.modify fA (+ 1)) second0) (Left "")+ , eq1 "get manual_mA_f" (Failing.get manual_mA_f second0) (Left "mA")+ , eq1 "set manual_mA_f" (Failing.set manual_mA_f record1 second0) (Left "mA")+ , eq1 "mod manual_mA_f" (Failing.modify manual_mA_f (Total.modify fA (+ 1)) second0) (Left "mA")+ , eq2 "set mA_f" (Failing.set' mA_f record1 first0) first2+ , eq2 "mod mA_f" (Failing.modify' mA_f (Total.modify fA (+ 1)) first0) first2+ , eq2 "set manual_mA_f" (Failing.set' manual_mA_f record1 first0) first2+ , eq2 "mod manual_mA_f" (Failing.modify' manual_mA_f (Total.modify fA (+ 1)) first0) first2+ , eq2 "set mA_f" (Failing.set' mA_f record1 second0) second0+ , eq2 "mod mA_f" (Failing.modify' mA_f (Total.modify fA (+ 1)) second0) second0+ , eq2 "set manual_mA_f" (Failing.set' manual_mA_f record1 second0) second0+ , eq2 "mod manual_mA_f" (Failing.modify' manual_mA_f (Total.modify fA (+ 1)) second0) second0+ , eq3 "get embed_fD" (Failing.get embed_fD record4) (Right True)+ , eq3 "set embed_fD" (Failing.set embed_fD False record4) (Right record5)+ , eq3 "mod embed_fD" (Failing.modify embed_fD not record4) (Right record5)+ , eq4 "get embed_fD" (Failing.get embed_fD record0) (Left 1)+ , eq4 "set embed_fD" (Failing.set embed_fD False record0) (Left 1)+ , eq4 "mod embed_fD" (Failing.modify embed_fD not record0) (Left 1)+ ] where eq0, eq1, eq2, eq3, eq4 :: (Eq a, Show a) => String -> a -> a -> Test+ eq0 x = equality ("failing mono " ++ x)+ eq1 x = equality ("failing mono fail " ++ x)+ eq2 x = equality ("failing mono prime " ++ x)+ eq3 x = equality ("failing mono embed " ++ x)+ eq4 x = equality ("failing mono embed fail " ++ x)++totalPoly :: Test+totalPoly = TestList+ [ eq "get dir" (Total.get dir north0) (0 :: Integer)+ , eq "set dir" (Total.set dir False north0) north1+ , eq "mod dir" (Total.modify dir (> 1) north0) north1+ , eq "get manual_dir" (Total.get manual_dir north0) 0+ , eq "set manual_dir" (Total.set manual_dir False north0) north1+ , eq "mod manual_dir" (Total.modify manual_dir (> 1) north0) north1+ ] where eq :: (Eq a, Show a) => String -> a -> a -> Test+ eq x = equality ("total mono " ++ x)++partialPoly :: Test+partialPoly = TestList+ [ eq0 "get north" (Partial.get north north0) (Just ())+ , eq0 "set north" (Partial.set north False north0) (Just north2)+ , eq0 "mod north" (Partial.modify north (> ()) north0) (Just north2)+ , eq1 "get north" (Partial.get north west0) Nothing+ , eq1 "set north" (Partial.set north False west0) Nothing+ , eq1 "mod north" (Partial.modify north (> ()) west0) Nothing+ ] where eq0, eq1 :: (Eq a, Show a) => String -> a -> a -> Test+ eq0 x = equality ("partial poly " ++ x)+ eq1 x = equality ("partial poly fail " ++ x)++failingPoly :: Test+failingPoly = TestList+ [ eq0 "get north" (Failing.get north_f north0) (Right ())+ , eq0 "set north" (Failing.set north_f False north0) (Right north2)+ , eq0 "mod north" (Failing.modify north_f (> ()) north0) (Right north2)+ , eq1 "get north" (Failing.get north_f west0) (Left "north")+ , eq1 "set north" (Failing.set north_f False west0) (Left "north")+ , eq1 "mod north" (Failing.modify north_f (> ()) west0) (Left "north")+ ] where eq0, eq1 :: (Eq a, Show a) => String -> a -> a -> Test+ eq0 x = equality ("failing poly " ++ x)+ eq1 x = equality ("failing poly fail " ++ x)++composition :: Test+composition = TestList+ [ eq0 "get id" (Partial.get id first0) (Just first0)+ , eq0 "set id" (Partial.set id first2 first0) (Just first2)+ , eq0 "mod id" (Partial.modify id (const first2) first0) (Just first2)+ , eq0 "get fAmA" (Partial.get fAmA first0) (Just 0)+ , eq0 "set fAmA" (Partial.set fAmA 1 first0) (Just first2)+ , eq0 "mod fAmA" (Partial.modify fAmA (+ 1) first0) (Just first2)+ , eq0 "get id fAmA" (Partial.get (id . fAmA) first0) (Just 0)+ , eq0 "set id fAmA" (Partial.set (id . fAmA) 1 first0) (Just first2)+ , eq0 "mod id fAmA" (Partial.modify (id . fAmA) (+ 1) first0) (Just first2)+ , eq0 "get fAmA id" (Partial.get (fAmA . id) first0) (Just 0)+ , eq0 "set fAmA id" (Partial.set (fAmA . id) 1 first0) (Just first2)+ , eq0 "mod fAmA id" (Partial.modify (fAmA . id) (+ 1) first0) (Just first2)+ ] where eq0 :: (Eq a, Show a) => String -> a -> a -> Test+ eq0 x = equality ("composition partial mono" ++ x)++applicativeTotal :: Test+applicativeTotal = TestList+ [ eq "get vA" (Total.get (vA . recordView) record0) Nothing+ , eq "get vB" (Total.get (vB . recordView) record0) (Left 1)+ , eq "get vC" (Total.get (vC . recordView) record0) newtype0+ , eq "set vA" (Total.set (vA . recordView) (Just newtype0) record2) record3+ , eq "modify vA" (Total.modify (vA . recordView) (fmap (const newtype0)) record2) record3++ , eq "get newtypeId" (Total.get newtypeId newtype0) newtype0+ , eq "set newtypeId" (Total.set newtypeId newtype1 newtype0) newtype1+ , eq "mod newtypeId" (Total.modify newtypeId (const newtype2) newtype0) newtype2+ ] where eq :: (Eq a, Show a) => String -> a -> a -> Test+ eq x = equality ("applicative total mono" ++ x)++myCon1 :: View2 Char+myCon1 = Con1 False ('a', 'z')++myCon2 :: View2 Char+myCon2 = Con2 True "abc"++applicativePartial :: Test+applicativePartial = TestList+ [ eq "get" (Partial.get (L.snd . L.left . view) myCon1) (Just ('a', 'z'))+ , eq "get" (Partial.get (L.snd . L.left . view) myCon2) Nothing+ , eq "get" (Partial.get (L.snd . L.right . view) myCon1) Nothing+ , eq "get" (Partial.get (L.snd . L.right . view) myCon2) (Just "abc")+ , eq "mod" (Partial.modify (L.fst . L.left . view) not myCon1) (Just (Con1 True ('a', 'z')))+ , eq "mod" (Partial.modify (L.fst . L.left . view) not myCon2) Nothing+ , eq "mod" (Partial.modify (L.fst . L.right . view) not myCon1) Nothing+ , eq "mod" (Partial.modify (L.fst . L.right . view) not myCon2) (Just (Con2 False "abc"))+ , eq "mod" (Partial.modify (L.snd . L.left . view) swap myCon1) (Just (Con1 False ('z', 'a')))+ , eq "mod" (Partial.modify (L.snd . L.left . view) swap myCon2) Nothing+ , eq "mod" (Partial.modify (L.snd . L.right . view) reverse myCon1) Nothing+ , eq "mod" (Partial.modify (L.snd . L.right . view) reverse myCon2) (Just (Con2 True "cba"))+ ] where eq :: (Eq a, Show a) => String -> a -> a -> Test+ eq x = equality ("applicative partial mono" ++ x)++bijections :: Test+bijections = TestList+ [ eq "get mulDiv" (get (iso mulDiv . fA) record0) 0+ , eq "set mulDiv" (set (iso mulDiv . fA) 1 record0) record10+ , eq "mod mulDiv" (modify (iso mulDiv . fA) (+ 1) record0) record10+ , eq "get addSub" (get (iso (inv addSub) . fA) record0) (-10)+ , eq "set addSub" (set (iso (inv addSub) . fA) 1 record0) record11+ , eq "mod addSub" (modify (iso (inv addSub) . fA) (+ 1) record0) record1++ , eq "get id mulDiv" (get (iso (id . mulDiv) . fA) record0) 0+ , eq "set id mulDiv" (set (iso (id . mulDiv) . fA) 1 record0) record10+ , eq "mod id mulDiv" (modify (iso (id . mulDiv) . fA) (+ 1) record0) record10+ , eq "get id mulDiv" (get (iso (mulDiv . id) . fA) record0) 0+ , eq "set id mulDiv" (set (iso (mulDiv . id) . fA) 1 record0) record10+ , eq "mod id mulDiv" (modify (iso (mulDiv . id) . fA) (+ 1) record0) record10+ ] where eq :: (Eq a, Show a) => String -> a -> a -> Test+ eq x = equality ("isomorphisms mono " ++ x)++monadic :: Test+monadic = TestList+ [ eq "asks id total" (runReader (Monadic.asks id) record0) record0+ , eq "asks fC total" (runReader (Monadic.asks fC) record0) newtype0+ , eq "gets id total" (evalState (Monadic.gets id) record0) record0+ , eq "gets fC total" (evalState (Monadic.gets fC) record0) newtype0++ , eq "put fA total" (execState (fA Monadic.=: 1) record0) record1+ , eq "modify fA total" (execState (fA Monadic.=. (+ 1)) record0) record1++ , eq "local fA total" (runReader (Monadic.local fA (+1) $ Monadic.asks id) record0) record1+ , eq "modifyAndGet fA total" (runState (Monadic.modifyAndGet fA (\a -> (a+10, a+1))) record0) (10, record1)+ ] where eq :: (Eq a, Show a) => String -> a -> a -> Test+ eq x = equality ("total monadic " ++ x)++base :: Test+base = TestList+ [ eq "get head" (Partial.get L.head [1, 2, 3]) (Just (1::Int))+ , eq "get head" (Partial.get L.head ([] :: [Int])) Nothing+ , eq "get tail" (Partial.get L.tail [1, 2, 3]) (Just [2, 3 ::Int])+ , eq "get tail" (Partial.get L.tail ([] :: [Int])) Nothing+ , eq "get left" (Partial.get L.left (Left 'a')) (Just 'a')+ , eq "get left" (Partial.get L.left (Right 'a' :: Either () Char)) Nothing+ , eq "get right" (Partial.get L.right (Right 'a')) (Just 'a')+ , eq "get right" (Partial.get L.right (Left 'a' :: Either Char ())) Nothing+ , eq "get just" (Partial.get L.just (Just 'a')) (Just 'a')+ , eq "get just" (Partial.get L.just (Nothing :: Maybe Char)) Nothing+ , eq "get fst" (Total.get (L.fst . L.swap) ('a', ())) ()+ , eq "get snd" (Total.get (L.snd . L.swap) ((), 'b')) ()+ , eq "get fst3" (Total.get L.fst3 ('a', (), ())) 'a'+ , eq "get snd3" (Total.get L.snd3 ((), 'b', ())) 'b'+ , eq "get trd3" (Total.get L.trd3 ((), (), 'c')) 'c'+ , eq "mod head" (Partial.modify L.head (*2) [1, 2, 3]) (Just [2, 2, 3::Int])+ , eq "mod head" (Partial.modify L.head (*2) ([]::[Int])) Nothing+ , eq "mod tail" (Partial.modify L.tail reverse [1, 2, 3]) (Just [1, 3, 2::Int])+ , eq "mod tail" (Partial.modify L.tail reverse ([]::[Int])) Nothing+ , eq "mod left" (Partial.modify L.left (=='a') (Left 'a')) (Just (Left True :: Either Bool ()))+ , eq "mod left" (Partial.modify L.left (=='a') (Right ())) (Nothing :: Maybe (Either Bool ()))+ , eq "mod right" (Partial.modify L.right (=='c') (Right 'b')) (Just (Right False :: Either () Bool))+ , eq "mod right" (Partial.modify L.right (=='c') (Left ())) (Nothing :: Maybe (Either () Bool))+ , eq "mod just" (Partial.modify L.just (=='a') (Just 'a')) (Just (Just True))+ , eq "mod just" (Partial.modify L.just (=='a') Nothing) Nothing+ , eq "mod fst" (Total.modify (L.fst . L.swap) (== 'a') ((), 'a')) ((), True)+ , eq "mod snd" (Total.modify (L.snd . L.swap) (== 'a') ('a', ())) (True, ())+ , eq "mod fst3" (Total.modify L.fst3 (== 'a') ('a', (), ())) (True, (), ())+ , eq "mod snd3" (Total.modify L.snd3 (== 'a') ((), 'b', ())) ((), False, ())+ , eq "mod trd3" (Total.modify L.trd3 (== 'a') ((), (), 'c')) ((), (), False)+ ] where eq :: (Eq a, Show a) => String -> a -> a -> Test+ eq x = equality ("base" ++ x)++equality :: (Eq a, Show a) => String -> a -> a -> Test+equality d a b = TestCase (assertEqual d b a)