fclabels-2.0.3.1/0000755000000000000000000000000012776525525011634 5ustar0000000000000000fclabels-2.0.3.1/CHANGELOG0000644000000000000000000001336012776525525013051 0ustar0000000000000000CHANGELOG 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. fclabels-2.0.3.1/fclabels.cabal0000644000000000000000000001050012776525525014367 0ustar0000000000000000Name: fclabels Version: 2.0.3.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 . * /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.2.4 to 2.0.3/ . > - Allow HUnit 1.4.*. > - Fix test suite on GHC 7.4. Maintainer: Sebastiaan Visser 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.8 Build-Type: Simple Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.1 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.10 , template-haskell >= 2.2 && < 2.12 , mtl >= 1.0 && < 2.3 , transformers >= 0.2 && < 0.6 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 >= 2.2 && < 2.12 , mtl >= 1.0 && < 2.3 , transformers >= 0.2 && < 0.6 , HUnit >= 1.2 && < 1.5 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.2 fclabels-2.0.3.1/LICENSE0000644000000000000000000000272412776525525012646 0ustar0000000000000000Copyright (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. fclabels-2.0.3.1/README.md0000644000000000000000000000341512776525525013116 0ustar0000000000000000# 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 fclabels-2.0.3.1/Setup.lhs0000644000000000000000000000011612776525525013442 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain fclabels-2.0.3.1/bench/0000755000000000000000000000000012776525525012713 5ustar0000000000000000fclabels-2.0.3.1/bench/Benchmark.hs0000644000000000000000000000277612776525525015155 0ustar0000000000000000{-# 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-2.0.3.1/src/0000755000000000000000000000000012776525525012423 5ustar0000000000000000fclabels-2.0.3.1/src/Data/0000755000000000000000000000000012776525525013274 5ustar0000000000000000fclabels-2.0.3.1/src/Data/Label.hs0000644000000000000000000001436512776525525014660 0ustar0000000000000000{-# 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 fclabels-2.0.3.1/src/Data/Label/0000755000000000000000000000000012776525525014313 5ustar0000000000000000fclabels-2.0.3.1/src/Data/Label/Base.hs0000644000000000000000000000621112776525525015521 0ustar0000000000000000{- | 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 fclabels-2.0.3.1/src/Data/Label/Derive.hs0000644000000000000000000006061712776525525016077 0ustar0000000000000000{- | 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,10,0) import Language.Haskell.TH hiding (classP) #else import Language.Haskell.TH #endif import Prelude hiding ((.), id) import qualified Data.Label.Mono as Mono import qualified Data.Label.Poly as Poly ------------------------------------------------------------------------------- -- 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 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] -- The type variables requiring forall. CxtQ -- The context. TypeQ -- The type. ExpQ -- The label body. | LabelExpr [TyVarBndr] -- The type variables requiring forall. CxtQ -- The context. TypeQ -- The type. ExpQ -- The label body. data Field c = Field (Maybe Name) -- Name of the field, when there is one. Bool -- Forced to be mono because of type shared with other fields. Type -- Type of the field. c -- Occurs in this/these constructors. deriving (Eq, Functor, Foldable) type Subst = [(Type, Type)] data Context = Context Int -- Field index. Name -- Constructor name. Con -- Constructor. deriving (Eq, Show) data Typing = Typing Bool -- Monomorphic type or polymorphic. TypeQ -- The lens input type. TypeQ -- The lens output type. [TyVarBndr] -- All used type variables. ------------------------------------------------------------------------------- mkLabelsWithForDec :: (String -> String) -> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec] mkLabelsWithForDec mk sigs concrete failing inl dec = do labels <- generateLabels mk concrete failing dec decls <- forM labels $ \l -> case l of LabelExpr {} -> return [] LabelDecl n i v c t b -> do bdy <- pure <$> funD n [clause [] (normalB b) []] prg <- if inl then pure <$> i else return [] typ <- if sigs then pure <$> sigD n (forallT v c t) else return [] return (concat [prg, typ, bdy]) return (concat decls) -- Generate the labels for all the record fields in the data type. generateLabels :: (String -> String) -> Bool -> Bool -> Dec -> Q [Label] generateLabels mk concrete failing dec = do -- Only process data and newtype declarations, filter out all -- constructors and the type variables. let (name, cons, vars) = case dec of #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] -> [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] -> 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] -> 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) (PlainTV . snd <$> subs))) isMonomorphic :: Type -> [TyVarBndr] -> Bool isMonomorphic field vars = let fieldVars = typeVariables field varNames = nameFromBinder <$> vars usedVars = filter (`elem` fieldVars) varNames in null usedVars ------------------------------------------------------------------------------- -- Generic helper functions dealing with Template Haskell typeVariables :: Type -> [Name] typeVariables = map nameFromBinder . binderFromType typeFromBinder :: TyVarBndr -> Type typeFromBinder (PlainTV tv ) = VarT tv #if MIN_VERSION_template_haskell(2,8,0) typeFromBinder (KindedTV tv StarT) = VarT tv #else typeFromBinder (KindedTV tv StarK) = VarT tv #endif typeFromBinder (KindedTV tv kind ) = SigT (VarT tv) kind binderFromType :: Type -> [TyVarBndr] binderFromType = go where go ty = case ty of ForallT ts _ _ -> ts AppT a b -> go a ++ go b SigT t _ -> go t VarT n -> [PlainTV n] _ -> [] 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 -> Name nameFromBinder (PlainTV n ) = n nameFromBinder (KindedTV n _) = n 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 -> TyVarBndr mapTyVarBndr f (PlainTV n ) = PlainTV (f n) mapTyVarBndr f (KindedTV n a) = KindedTV (f n) a -- Prettify a TH name. pretty :: Name -> Name pretty tv = mkName (takeWhile (/= '_') (show tv)) -- Prettify a type. prettyType :: Type -> Type prettyType = mapTypeVariables pretty -- Reify a name into a declaration. reifyDec :: Name -> Q Dec reifyDec name = do info <- reify name case info of TyConI dec -> return dec _ -> fclError "Info must be type declaration type." -- Throw a fclabels specific error. fclError :: String -> a fclError err = error ("Data.Label.Derive: " ++ err) #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 fclabels-2.0.3.1/src/Data/Label/Failing.hs0000644000000000000000000000550312776525525016223 0ustar0000000000000000{-| 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) fclabels-2.0.3.1/src/Data/Label/Monadic.hs0000644000000000000000000000375712776525525016235 0ustar0000000000000000{-| 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 fclabels-2.0.3.1/src/Data/Label/Mono.hs0000644000000000000000000000365212776525525015565 0ustar0000000000000000{- | 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 fclabels-2.0.3.1/src/Data/Label/Partial.hs0000644000000000000000000000574112776525525016252 0ustar0000000000000000{-| 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))) fclabels-2.0.3.1/src/Data/Label/Point.hs0000644000000000000000000001154512776525525015746 0ustar0000000000000000{- | The Point data type which generalizes the different lenses and forms the basis for vertical composition using the `Applicative` type class. -} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TypeOperators , Arrows , FlexibleInstances , MultiParamTypeClasses , 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 Prelude hiding ((.), id, const, curry, uncurry) {-# INLINE get #-} {-# INLINE modify #-} {-# INLINE set #-} {-# INLINE identity #-} {-# INLINE compose #-} {-# INLINE inv #-} {-# INLINE const #-} {-# INLINE curry #-} ------------------------------------------------------------------------------- -- | Abstract Point datatype. The getter and modifier operations work in some -- category. The type of the value pointed to might change, thereby changing -- the type of the outer structure. data Point cat g i f o = Point (cat f o) (cat (cat o i, f) g) -- | Get the getter category from a Point. get :: Point cat g i f o -> cat f o get (Point g _) = g -- | Get the modifier category from a Point. modify :: Point cat g i f o -> cat (cat o i, f) g modify (Point _ m) = m -- | Get the setter category from a Point. set :: Arrow arr => Point arr g i f o -> arr (i, f) g set p = modify p . first (arr const) -- | Identity Point. Cannot change the type. identity :: ArrowApply arr => Point arr f f o o identity = Point id app -- | Point composition. compose :: ArrowApply cat => Point cat t i b o -> Point cat g t f b -> Point cat g i f o compose (Point f m) (Point g n) = Point (f . g) (uncurry (curry n . curry m)) ------------------------------------------------------------------------------- instance Arrow arr => Functor (Point arr f i f) where fmap f x = pure f <*> x {-# INLINE fmap #-} instance Arrow arr => Applicative (Point arr f i f) where pure a = Point (const a) (arr snd) a <*> b = Point (arr app . (get a &&& get b)) $ proc (t, p) -> do (f, v) <- get a &&& get b -< p q <- modify a -< (t . arr ($ v), p) modify b -< (t . arr f, q) {-# INLINE pure #-} {-# INLINE (<*>) #-} instance Alternative (Point Partial f view f) where empty = Point zeroArrow zeroArrow Point a b <|> Point c d = Point (a <|> c) (b <|> d) ------------------------------------------------------------------------------- infix 8 `Iso` -- | An isomorphism is like a `Category` that works in two directions. data Iso cat i o = Iso { fw :: cat i o, bw :: cat o i } -- | Isomorphisms are categories. instance Category cat => Category (Iso cat) where id = Iso id id Iso a b . Iso c d = Iso (a . c) (d . b) {-# INLINE id #-} {-# INLINE (.) #-} -- | Flip an isomorphism. inv :: Iso cat i o -> Iso cat o i inv i = Iso (bw i) (fw i) ------------------------------------------------------------------------------- -- | Context that represents computations that always produce an output. type Total = (->) -- | Context that represents computations that might silently fail. type Partial = Kleisli Maybe -- | Context that represents computations that might fail with some error. type Failing e = Kleisli (Either e) -- | The ArrowFail class is similar to `ArrowZero`, but additionally embeds -- some error value in the computation instead of throwing it away. class Arrow a => ArrowFail e a where failArrow :: a e c instance ArrowFail e Partial where failArrow = Kleisli (const Nothing) {-# INLINE failArrow #-} instance ArrowFail e (Failing e) where failArrow = Kleisli Left {-# INLINE failArrow #-} ------------------------------------------------------------------------------- -- | Missing Functor instance for Kleisli. instance Functor f => Functor (Kleisli f i) where fmap f (Kleisli m) = Kleisli (fmap f . m) -- | Missing Applicative instance for Kleisli. instance Applicative f => Applicative (Kleisli f i) where pure a = Kleisli (const (pure a)) Kleisli a <*> Kleisli b = Kleisli ((<*>) <$> a <*> b) -- | Missing Alternative instance for Kleisli. instance Alternative f => Alternative (Kleisli f i) where empty = Kleisli (const empty) Kleisli a <|> Kleisli b = Kleisli ((<|>) <$> a <*> b) ------------------------------------------------------------------------------- -- Common operations experessed in a generalized form. const :: Arrow arr => c -> arr b c const a = arr (\_ -> a) curry :: Arrow cat => cat (a, b) c -> (a -> cat b c) curry m i = m . (const i &&& id) uncurry :: ArrowApply cat => (a -> cat b c) -> cat (a, b) c uncurry a = app . arr (first a) fclabels-2.0.3.1/src/Data/Label/Poly.hs0000644000000000000000000000617312776525525015601 0ustar0000000000000000{- | 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 fclabels-2.0.3.1/src/Data/Label/Total.hs0000644000000000000000000000377112776525525015742 0ustar0000000000000000{-| 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) fclabels-2.0.3.1/test/0000755000000000000000000000000012776525525012613 5ustar0000000000000000fclabels-2.0.3.1/test/TestSuite.hs0000644000000000000000000006001312776525525015100 0ustar0000000000000000{- 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)