fclabels 0.1.2 → 2.0.5.1
raw patch · 19 files changed
Files
- CHANGELOG +254/−0
- Data/Record/Label.hs +0/−86
- Data/Record/Label/TH.hs +0/−49
- LICENCE +0/−28
- LICENSE +28/−0
- README.md +42/−0
- bench/Benchmark.hs +58/−0
- fclabels.cabal +123/−17
- src/Data/Label.hs +211/−0
- src/Data/Label/Base.hs +117/−0
- src/Data/Label/Derive.hs +729/−0
- src/Data/Label/Failing.hs +93/−0
- 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/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.
− Data/Record/Label.hs
@@ -1,86 +0,0 @@-module Data.Record.Label (- Getter, Setter, Modifier- , Label (..)- , lmod- , (%), comp- , getM, setM, modM- , bothM- , enterM, enterMT- , withM, localM- , list- , module Data.Record.Label.TH- ) where--import Control.Monad.State-import Data.Record.Label.TH--type Getter a b = a -> b-type Setter a b = b -> a -> a-type Modifier a b = (b -> b) -> a -> a--data Label a b = Label {- lget :: Getter a b- , lset :: Setter a b- }--lmod :: Label a b -> Modifier a b-lmod l f a = lset l (f (lget l a)) a--infixr 8 %--(%) :: Label t a -> Label b t -> Label b a-a % b = Label (lget a . lget b) (lmod b . lset a)---- Apply custom `parser' and 'printer' function.--comp :: (b -> c) -> (c -> b) -> Label t b -> Label t c-comp f g (Label a b) = Label (f . a) (\v -> b $ g v)---- Extend the state monad with support for labels.--getM :: MonadState s m => Label s b -> m b-getM = gets . lget--setM :: MonadState s m => Label s b -> b -> m ()-setM l = modify . lset l--modM :: MonadState s m => Label s b -> (b -> b) -> m ()-modM l = modify . lmod l---- Run a state computation for a sub element updating this part of the state afterwards.--enterM :: MonadState s m => Label s b -> State b a -> m a-enterM l c = do- b <- getM l- let (a, s) = runState c b- setM l s- return a--enterMT :: (MonadState s (t m), MonadTrans t, Monad m) => Label s b -> StateT b m a -> t m a-enterMT l c = do- b <- getM l- (a, s) <- lift $ runStateT c b- setM l s- return a--bothM :: MonadState s m => Label s b -> State b a -> m (b, a)-bothM parent cmp = do- p <- getM parent- c <- enterM parent cmp- return (p, c)--localM :: MonadState s m => Label s b -> m c -> m c-localM l comp = do- k <- getM l- c <- comp- setM l k- return c--withM :: MonadState s m => Label s b -> State b a -> m c -> m c-withM l c d = localM l (enterM l c >> d)---- Lift list indexing to a label.--list :: Int -> Label [a] a-list i = Label (!! i) (\v a -> take i a ++ [v] ++ drop (i+1) a)-
− Data/Record/Label/TH.hs
@@ -1,49 +0,0 @@-module Data.Record.Label.TH (mkLabels) where--import Control.Monad (liftM)-import Data.Char (toLower, toUpper)-import Language.Haskell.TH ( Body (NormalB)- , Clause (Clause)- , Con (RecC)- , Dec (DataD, FunD)- , Exp (AppE, ConE, LamE, RecUpdE, VarE)- , Info (TyConI)- , Name- , Pat (VarP)- , Q- , mkName- , nameBase- , reify)-import Language.Haskell.TH.Syntax (VarStrictType)--mkLabels :: [Name] -> Q [Dec]-mkLabels = liftM concat . mapM mkLabels1--mkLabels1 :: Name -> Q [Dec]-mkLabels1 n = do- i <- reify n- let cs = case i of- TyConI (DataD _ _ _ cs _) -> cs -- only process data declarations- _ -> []- ls = [ l | (RecC _ ls) <- cs, l <- ls ] -- we're only interested in labels of record constructors- return $ map mkLabel ls--mkLabel :: VarStrictType -> Dec-mkLabel (name, _, ty) =- -- Generate a name for the label:- -- * If the original selector starts with an _, remove it and make- -- the next character lowercase.- -- * Otherwise, add 'l', and make the next character uppercase.- let n = mkName $ case nameBase name of- ('_' : c : rest) -> toLower c : rest- (f : rest) -> 'l' : toUpper f : rest- in FunD n [Clause [] (NormalB (- AppE (AppE (ConE (mkName "Label"))- (VarE name)) -- getter- (LamE [VarP (mkName "b"), VarP (mkName "a")] -- setter- (RecUpdE (VarE (mkName "a")) [(name, VarE (mkName "b"))]))- )) []]--isRec :: Con -> Bool-isRec (RecC _ _) = True-isRec _ = False
− LICENCE
@@ -1,28 +0,0 @@-Copyright (c) Erik Hesselink & Sebastiaan Visser 2008--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:-1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.-3. Neither the name of the author nor the names of his contributors- may be used to endorse or promote products derived from this software- without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF-SUCH DAMAGE.-
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) Erik Hesselink & Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.+
+ 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,18 +1,124 @@-name: fclabels-version: 0.1.2-author: Sebastiaan Visser, Erik Hesselink-synopsis: First class record labels-description: First class labels for records, with combinators, allowing- selection, modification and update inside (nested) records.- Also includes MonadState versions of these, and template- haskell generation of the labels.-maintainer: Sebastiaan Visser <sfvisser@cs.uu.nl>-license: BSD3-license-file: LICENCE-category: Data-build-type: Simple-cabal-version: >= 1.6-exposed-modules: Data.Record.Label-other-modules: Data.Record.Label.TH+Name: fclabels+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 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. 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 or see the+ introductory blog post at+ <http://fvisser.nl/post/2013/okt/1/fclabels-2.0.html>+ .+ * /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 "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.+ .+ * /Changelog from 2.0.4 to 2.0.5/+ .+ > - Support for GHC 8.10. Thanks to Potato Hatsue. -build-depends: base >= 3 && < 5, template-haskell >= 2.2 && < 2.4, monads-fd ==0.0.*+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.Base+ Data.Label.Derive+ 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 >= 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
@@ -0,0 +1,211 @@+{-# LANGUAGE TypeOperators #-}+{- |+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.+-}++module Data.Label+(++-- * Working with @fclabels@.++{- |+The lens datatype, conveniently called `:->', is an instance of the+"Control.Category" type class: meaning it has a proper identity and+composition. The library has support for automatically deriving labels from+record selectors that start with an underscore.++To illustrate this package, let's take the following two example datatypes.+-}++-- |+-- >{-# LANGUAGE TemplateHaskell, TypeOperators #-}+-- >import Control.Category+-- >import Data.Label+-- >import Prelude hiding ((.), id)+-- >+-- >data Person = Person+-- > { _name :: String+-- > , _age :: Int+-- > , _place :: Place+-- > } deriving Show+-- >+-- >data Place = Place+-- > { _city+-- > , _country+-- > , _continent :: String+-- > } deriving Show++{- |+Both datatypes are record types with all the labels prefixed with an+underscore. This underscore is an indication for our Template Haskell code to+derive lenses for these fields. Deriving lenses can be done with this simple+one-liner:++>mkLabels [''Person, ''Place]++For all labels a lens will created.++Now let's look at this example. This 71 year old fellow, my neighbour called+Jan, didn't mind using him as an example:++>jan :: Person+>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:++>hisAge :: Int+>hisAge = get age jan++Consider he now wants to move to Amsterdam: what better place to spend your old+days. Using composition we can change the city value deep inside the structure:++>moveToAmsterdam :: Person -> Person+>moveToAmsterdam = set (city . place) "Amsterdam"++And now:++>ghci> moveToAmsterdam jan+>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+@(`.`)@, `id` function from the Haskell "Prelude".++-}++-- * Total monomorphic lenses.++ (:->)+, lens+, get+, set+, modify++-- * Vertical composition using @Applicative@.++{- |++Now, because Jan is an old guy, moving to another city is not a very easy task,+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:++>import Control.Applicative++>(fstL, sndL) = $(getLabel ''(,))++>ageAndCity :: Person :-> (Int, String)+>ageAndCity = point $+> (,) <$> fstL >- age+> <*> sndL >- city . place++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 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+is itself a lens again), we can use the `modify` function to make Jan move to+Amsterdam over exactly two years:++>moveToAmsterdamOverTwoYears :: Person -> Person+>moveToAmsterdamOverTwoYears = modify ageAndCity (\(a, _) -> (a+2, "Amsterdam"))++>ghci> moveToAmsterdamOverTwoYears jan+>Person "Jan" 73 True (Place "Amsterdam" "The Netherlands" "Europe")++-}++, point+, (>-)+, for++-- * 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 = iso (Iso show read) . age++, Iso (..)+, inv+, iso++-- * Derive labels using Template Haskell.+--+-- | 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".++, mkLabel+, mkLabels+, getLabel+, fclabels+)+where++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/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
@@ -0,0 +1,729 @@+{- |+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+ DeriveFunctor+ , DeriveFoldable+ , TemplateHaskell+ , TypeOperators+ , CPP #-}++module Data.Label.Derive+(++-- * Generate labels in scope.+ mkLabel+, mkLabels+, mkLabelsNamed++-- * Produce labels as expressions.+, getLabel++-- * First class record labels.+, fclabels++-- * Low level derivation functions.+, mkLabelsWith+, getLabelWith+, defaultNaming+)+where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Monad+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++#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)++import qualified Data.Label.Mono as Mono+import qualified Data.Label.Poly as Poly+++#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 = liftM concat . mapM (mkLabelsWith defaultNaming True False False True)++-- | 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++-- | 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 }@.++mkLabelsNamed :: (String -> String) -> [Name] -> Q [Dec]+mkLabelsNamed mk = liftM concat . mapM (mkLabelsWith mk True False False True)++-- | 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.++getLabel :: Name -> Q Exp+getLabel = getLabelWith True False False++-- | Low level label as expression derivation function.++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++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++-- | Low level standalone label derivation function.++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]++mkLabelsWith mk sigs concrete failing inl name =+ do dec <- reifyDec name+ mkLabelsWithForDec mk sigs concrete failing inl dec++-- | 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.++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 labels for all the record types in the supplied declaration. The+-- record fields don't need an underscore prefix. Multiple data types /+-- newtypes are allowed at once.+--+-- The advantage of this approach is that you don't need to explicitly hide the+-- original record accessors from being exported and they won't show up in the+-- derived `Show` instance.+--+-- Example:+--+-- > fclabels [d|+-- > data Record = Record+-- > { int :: Int+-- > , bool :: Bool+-- > } deriving Show+-- > |]+--+-- > ghci> modify int (+2) (Record 1 False)+-- > Record 3 False++fclabels :: Q [Dec] -> Q [Dec]+fclabels decls =+ do ds <- decls+ ls <- forM (ds >>= labels) (mkLabelsWithForDec id True False False False)+ return (concat ((delabelize <$> ds) : ls))+ where++ 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++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)+ -- 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+ let inline = InlineP n (InlineSpec True True (Just (True, 0)))+#endif+ in LabelDecl n (return (PragmaD inline)) tvs cont ty body++-- Build a total polymorphic modification function from a getter and setter.++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 #-}++-------------------------------------------------------------------------------++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)++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))++freshNames :: [String]+freshNames = map pure ['a'..'z'] ++ map (('a':) . show) [0 :: Integer ..]++-------------------------------------------------------------------------------++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++typeVariables :: Type -> [Name]+typeVariables = map nameFromBinder . binderFromType++typeFromBinder :: TyVarBndr a -> Type+#if MIN_VERSION_template_haskell(2,17,0)+typeFromBinder (PlainTV tv _) = VarT tv+#else+typeFromBinder (PlainTV tv ) = VarT tv+#endif++#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 = mapTypeVariables pretty++-- Reify a name into a declaration.++reifyDec :: Name -> Q Dec+reifyDec name =+ do info <- reify name+ case info of+ TyConI dec -> return dec+ _ -> fclError "Info must be type declaration type."++-- Throw a fclabels specific error.++fclError :: String -> a+fclError err = error ("Data.Label.Derive: " ++ err)++#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/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/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)