├── cabal.project ├── .gitignore ├── test ├── .gitignore ├── .ghci └── TestSuite.hs ├── Setup.lhs ├── bench ├── run.sh └── Benchmark.hs ├── LICENSE ├── README.md ├── src └── Data │ ├── Label │ ├── Mono.hs │ ├── Monadic.hs │ ├── Total.hs │ ├── Failing.hs │ ├── Partial.hs │ ├── Base.hs │ ├── Poly.hs │ ├── Point.hs │ └── Derive.hs │ └── Label.hs ├── .travis.yml ├── fclabels.cabal └── CHANGELOG /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle 3 | -------------------------------------------------------------------------------- /test/.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .hpc/ 3 | -------------------------------------------------------------------------------- /test/.ghci: -------------------------------------------------------------------------------- 1 | :set -i../src 2 | :set -hide-package=fclabels 3 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain 5 | -------------------------------------------------------------------------------- /bench/run.sh: -------------------------------------------------------------------------------- 1 | mkdir dist 2 | ghc -odir dist -hidir dist --make -O Benchmark.hs -o dist/benchmark -fforce-recomp 3 | dist/benchmark 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Erik Hesselink & Sebastiaan Visser 2008 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. Neither the name of the author nor the names of his contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | 29 | -------------------------------------------------------------------------------- /bench/Benchmark.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | import Data.Label 4 | import Prelude hiding ((.), id) 5 | import Control.Category 6 | import Criterion.Main 7 | 8 | data Person = Person 9 | { _name :: String 10 | , _age :: Int 11 | , _place :: Place 12 | , _birthplace :: Maybe Place 13 | } deriving (Show, Eq) 14 | 15 | data Place = Place 16 | { _city 17 | , _country 18 | , _continent :: String 19 | } deriving (Show, Eq) 20 | 21 | mkLabels [''Person, ''Place] 22 | 23 | jan :: Person 24 | jan = Person "Jan" 71 (Place "Utrecht" "The Netherlands" "Europe") Nothing 25 | 26 | getAge :: Int 27 | getAge = get age jan 28 | 29 | moveToAmsterdam :: Person -> Person 30 | moveToAmsterdam = set (city . place) "Amsterdam" 31 | 32 | moveToAmsterdam' :: Person -> Person 33 | moveToAmsterdam' person = person{_place = (_place person){_city = "Amsterdam"}} 34 | 35 | ageByOneYear :: Person -> Person 36 | ageByOneYear = modify age (+1) 37 | 38 | ageByOneYear' :: Person -> Person 39 | ageByOneYear' person = person{_age = (+1) $ _age person} 40 | 41 | moveAndAge :: Person -> Person 42 | moveAndAge = ageByOneYear . moveToAmsterdam . ageByOneYear . ageByOneYear . ageByOneYear 43 | 44 | moveAndAge' :: Person -> Person 45 | moveAndAge' = ageByOneYear' . moveToAmsterdam' . ageByOneYear' . ageByOneYear' . ageByOneYear' 46 | 47 | main :: IO () 48 | main = 49 | defaultMain 50 | [ bench "warmup" $ whnf show "Hello World" 51 | , bench "ageByOneYear" $ whnf ageByOneYear jan 52 | , bench "ageByOneYear'" $ whnf ageByOneYear' jan 53 | , bench "moveToAmsterdam" $ whnf moveToAmsterdam jan 54 | , bench "moveToAmsterdam'" $ whnf moveToAmsterdam' jan 55 | , bench "moveAndAge" $ whnf moveAndAge jan 56 | , bench "moveAndAge'" $ whnf moveAndAge' jan 57 | ] 58 | 59 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # fclabels: first class accessor labels 2 | 3 | This package provides first class labels that can act as bidirectional record 4 | fields. The labels can be derived automatically using Template Haskell which 5 | means you don't have to write any boilerplate yourself. The labels are 6 | implemented as _lenses_ and are fully composable. Lenses can be used to _get_, 7 | _set_ and _modify_ parts of a data type in a consistent way. 8 | 9 | See `Data.Label` for an introductory explanation. 10 | 11 | ### Total and partial lenses 12 | 13 | Internally lenses do not use Haskell functions directly, but are implemented 14 | as categories. Categories allow the lenses to be run in custom computational 15 | contexts. This approach allows us to make partial lenses that point to fields 16 | of multi-constructor datatypes in an elegant way. 17 | 18 | See `Data.Label.Partial` for the use of partial labels. 19 | 20 | ### Monomorphic and polymorphic lenses 21 | 22 | We have both polymorphic and monomorphic lenses. Polymorphic lenses allow 23 | updates that change the type. The types of polymorphic lenses are slightly more 24 | verbose than their monomorphic counterparts, but their usage is similar. 25 | Because monomorphic lenses are built by restricting the types of polymorphic 26 | lenses they are essentially the same and can be freely composed with eachother. 27 | 28 | See `Data.Label.Mono` and `Data.Label.Poly` for the difference between 29 | polymorphic and monomorphic lenses. 30 | 31 | ### Using fclabels 32 | 33 | To simplify working with labels we supply both a set of labels for Haskell's 34 | base types, like lists, tuples, Maybe and Either, and we supply a set of 35 | combinators for working with labels for values in the Reader and State monad. 36 | 37 | See `Data.Label.Base` and `Data.Label.Monadic` for more information. 38 | 39 | On Hackage: http://hackage.haskell.org/package/fclabels 40 | 41 | Introduction: http://fvisser.nl/post/2013/okt/1/fclabels-2.0.html 42 | 43 | -------------------------------------------------------------------------------- /src/Data/Label/Mono.hs: -------------------------------------------------------------------------------- 1 | {- | Lenses that only allow monomorphic updates. Monomorphic lenses are simply 2 | polymorphic lenses with the input and output type variables constraint to the 3 | same type. -} 4 | 5 | {-# LANGUAGE 6 | FlexibleInstances 7 | , MultiParamTypeClasses 8 | , TypeOperators 9 | #-} 10 | 11 | module Data.Label.Mono 12 | ( Lens 13 | , lens 14 | , get 15 | , modify 16 | , point 17 | , set 18 | , iso 19 | 20 | -- * Specialized monomorphic lens operators. 21 | , (:->) 22 | , (:~>) 23 | ) 24 | where 25 | 26 | import Control.Category 27 | import Control.Arrow 28 | import Data.Label.Point (Point, Iso (..), Total, Partial) 29 | import Prelude () 30 | 31 | import qualified Data.Label.Poly as Poly 32 | 33 | {-# INLINE lens #-} 34 | {-# INLINE get #-} 35 | {-# INLINE modify #-} 36 | {-# INLINE set #-} 37 | {-# INLINE point #-} 38 | {-# INLINE iso #-} 39 | 40 | ------------------------------------------------------------------------------- 41 | 42 | -- | Abstract monomorphic lens datatype. The getter and setter functions work 43 | -- in some category. Categories allow for effectful lenses, for example, lenses 44 | -- that might fail or use state. 45 | 46 | type Lens cat f o = Poly.Lens cat (f -> f) (o -> o) 47 | 48 | -- | Create a lens out of a getter and setter. 49 | 50 | lens :: cat f o -- ^ Getter. 51 | -> (cat (cat o o, f) f) -- ^ Modifier. 52 | -> Lens cat f o 53 | lens = Poly.lens 54 | 55 | -- | Get the getter arrow from a lens. 56 | 57 | get :: Lens cat f o -> cat f o 58 | get = Poly.get 59 | 60 | -- | Get the modifier arrow from a lens. 61 | 62 | modify :: Lens cat f o -> cat (cat o o, f) f 63 | modify = Poly.modify 64 | 65 | -- | Get the setter arrow from a lens. 66 | 67 | set :: Arrow arr => Lens arr f o -> arr (o, f) f 68 | set = Poly.set 69 | 70 | -- | Create lens from a `Point`. 71 | 72 | point :: Point cat f o f o -> Lens cat f o 73 | point = Poly.point 74 | 75 | -- | Lift an isomorphism into a `Lens`. 76 | 77 | iso :: ArrowApply cat => Iso cat f o -> Lens cat f o 78 | iso (Iso f b) = lens f (app . arr (\(m, v) -> (b . m . f, v))) 79 | 80 | ------------------------------------------------------------------------------- 81 | 82 | -- | Total monomorphic lens. 83 | 84 | type f :-> o = Lens Total f o 85 | 86 | -- | Partial monomorphic lens. 87 | 88 | type f :~> o = Lens Partial f o 89 | 90 | -------------------------------------------------------------------------------- /src/Data/Label/Monadic.hs: -------------------------------------------------------------------------------- 1 | {-| State and Reader operations specialized for working with total lenses. -} 2 | 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module Data.Label.Monadic 6 | ( 7 | -- * 'MonadState' lens operations. 8 | gets 9 | , puts 10 | , modify 11 | , modifyAndGet 12 | , (=:) 13 | , (=.) 14 | 15 | -- * 'MonadReader' lens operations. 16 | , asks 17 | , local 18 | ) 19 | where 20 | 21 | import Control.Monad 22 | import Data.Label.Mono (Lens) 23 | 24 | import qualified Data.Label.Total as Total 25 | import qualified Control.Monad.Reader as Reader 26 | import qualified Control.Monad.State as State 27 | 28 | -- | Get a value out of the state, pointed to by the specified lens. 29 | 30 | gets :: State.MonadState f m => Lens (->) f o -> m o 31 | gets = State.gets . Total.get 32 | 33 | -- | Set a value somewhere in the state, pointed to by the specified lens. 34 | 35 | puts :: State.MonadState f m => Lens (->) f o -> o -> m () 36 | puts l = State.modify . Total.set l 37 | 38 | -- | Modify a value with a function somewhere in the state, pointed to by the 39 | -- specified lens. 40 | 41 | modify :: State.MonadState f m => Lens (->) f o -> (o -> o) -> m () 42 | modify l = State.modify . Total.modify l 43 | 44 | -- | Alias for `puts' that reads like an assignment. 45 | 46 | infixr 2 =: 47 | (=:) :: State.MonadState f m => Lens (->) f o -> o -> m () 48 | (=:) = puts 49 | 50 | -- | Alias for `modify' that reads more or less like an assignment. 51 | 52 | infixr 2 =. 53 | (=.) :: State.MonadState f m => Lens (->) f o -> (o -> o) -> m () 54 | (=.) = modify 55 | 56 | -- | Fetch a value pointed to by a lens out of a reader environment. 57 | 58 | asks :: Reader.MonadReader f m => (Lens (->) f o) -> m o 59 | asks = Reader.asks . Total.get 60 | 61 | -- | Execute a computation in a modified environment. The lens is used to 62 | -- point out the part to modify. 63 | 64 | local :: Reader.MonadReader f m => (Lens (->) f o) -> (o -> o) -> m a -> m a 65 | local l f = Reader.local (Total.modify l f) 66 | 67 | -- | Modify a value with a function somewhere in the state, pointed to by the 68 | -- specified lens. Additionally return a separate value based on the 69 | -- modification. 70 | 71 | modifyAndGet :: State.MonadState f m => (Lens (->) f o) -> (o -> (a, o)) -> m a 72 | modifyAndGet l f = 73 | do (b, a) <- f `liftM` gets l 74 | puts l a 75 | return b 76 | 77 | -------------------------------------------------------------------------------- /src/Data/Label/Total.hs: -------------------------------------------------------------------------------- 1 | {-| Default lenses for simple total getters and total possibly polymorphic, 2 | updates. Useful for creating accessor labels for single constructor datatypes. 3 | Also useful field labels that are shared between all the constructors of a 4 | multi constructor datatypes. 5 | -} 6 | 7 | {-# LANGUAGE CPP, TypeOperators #-} 8 | 9 | module Data.Label.Total 10 | ( (:->) 11 | , Total 12 | , lens 13 | , get 14 | , modify 15 | , set 16 | 17 | -- * Working in contexts. 18 | , traverse 19 | , lifted 20 | ) 21 | where 22 | 23 | #if MIN_VERSION_base(4,8,0) 24 | import Prelude hiding (traverse) 25 | #endif 26 | import Control.Monad ((<=<), liftM) 27 | import Data.Label.Poly (Lens) 28 | import Data.Label.Point (Total) 29 | 30 | import qualified Data.Label.Poly as Poly 31 | 32 | {-# INLINE lens #-} 33 | {-# INLINE get #-} 34 | {-# INLINE modify #-} 35 | {-# INLINE set #-} 36 | 37 | ------------------------------------------------------------------------------- 38 | 39 | -- | Total lens type specialized for total accessor functions. 40 | 41 | type f :-> o = Lens Total f o 42 | 43 | -- | Create a total lens from a getter and a modifier. 44 | -- 45 | -- We expect the following law to hold: 46 | -- 47 | -- > get l (set l a f) == a 48 | -- 49 | -- > set l (get l f) f == f 50 | 51 | lens :: (f -> o) -- ^ Getter. 52 | -> ((o -> i) -> f -> g) -- ^ Modifier. 53 | -> (f -> g) :-> (o -> i) 54 | lens g s = Poly.lens g (uncurry s) 55 | 56 | -- | Get the getter function from a lens. 57 | 58 | get :: ((f -> g) :-> (o -> i)) -> f -> o 59 | get = Poly.get 60 | 61 | -- | Get the modifier function from a lens. 62 | 63 | modify :: (f -> g) :-> (o -> i) -> (o -> i) -> f -> g 64 | modify = curry . Poly.modify 65 | 66 | -- | Get the setter function from a lens. 67 | 68 | set :: ((f -> g) :-> (o -> i)) -> i -> f -> g 69 | set = curry . Poly.set 70 | 71 | -- | Modify in some context. 72 | 73 | traverse :: Functor m => (f -> g) :-> (o -> i) -> (o -> m i) -> f -> m g 74 | traverse l m f = (\w -> set l w f) `fmap` m (get l f) 75 | 76 | 77 | -- | Lifted lens composition. 78 | -- 79 | -- For example, useful when specialized to lists: 80 | -- 81 | -- > :: (f :-> [o]) 82 | -- > -> (o :-> [a]) 83 | -- > -> (f :-> [a]) 84 | 85 | lifted 86 | :: Monad m 87 | => (f -> g) :-> (m o -> m i) 88 | -> (o -> i) :-> (m a -> m b) 89 | -> (f -> g) :-> (m a -> m b) 90 | lifted a b = lens (get b <=< get a) (modify a . liftM . modify b) 91 | 92 | -------------------------------------------------------------------------------- /src/Data/Label/Failing.hs: -------------------------------------------------------------------------------- 1 | {-| Lenses for getters and updates that can potentially fail with some error 2 | value. Like partial lenses, failing lenses are useful for creating accessor 3 | labels for multi constructor data types where projection and modification of 4 | fields will not always succeed. The error value can be used to report what 5 | caused the failure. 6 | -} 7 | 8 | {-# LANGUAGE TypeOperators, TupleSections #-} 9 | 10 | module Data.Label.Failing 11 | ( Lens 12 | , Failing 13 | , lens 14 | , get 15 | , modify 16 | , set 17 | , embed 18 | 19 | -- * Seemingly total modifications. 20 | , set' 21 | , modify' 22 | ) 23 | where 24 | 25 | import Control.Applicative 26 | import Control.Arrow 27 | import Control.Category 28 | import Data.Label.Point (Failing) 29 | import Prelude hiding ((.), id) 30 | 31 | import qualified Data.Label.Poly as Poly 32 | 33 | {-# INLINE lens #-} 34 | {-# INLINE get #-} 35 | {-# INLINE modify #-} 36 | {-# INLINE set #-} 37 | {-# INLINE embed #-} 38 | {-# INLINE set' #-} 39 | {-# INLINE modify' #-} 40 | 41 | -- | Lens type for situations in which the accessor functions can fail with 42 | -- some error information. 43 | 44 | type Lens e f o = Poly.Lens (Failing e) f o 45 | 46 | ------------------------------------------------------------------------------- 47 | 48 | -- | Create a lens that can fail from a getter and a modifier that can 49 | -- themselves potentially fail. 50 | 51 | lens :: (f -> Either e o) -- ^ Getter. 52 | -> ((o -> Either e i) -> f -> Either e g) -- ^ Modifier. 53 | -> Lens e (f -> g) (o -> i) 54 | lens g s = Poly.lens (Kleisli g) (Kleisli (\(m, f) -> s (runKleisli m) f)) 55 | 56 | -- | Getter for a lens that can fail. When the field to which the lens points 57 | -- is not accessible the getter returns 'Nothing'. 58 | 59 | get :: Lens e (f -> g) (o -> i) -> f -> Either e o 60 | get l = runKleisli (Poly.get l) 61 | 62 | -- | Modifier for a lens that can fail. When the field to which the lens points 63 | -- is not accessible this function returns 'Left'. 64 | 65 | modify :: Lens e (f -> g) (o -> i) -> (o -> i) -> f -> Either e g 66 | modify l m = runKleisli (Poly.modify l . arr (arr m,)) 67 | 68 | -- | Setter for a lens that can fail. When the field to which the lens points 69 | -- is not accessible this function returns 'Left'. 70 | 71 | set :: Lens e (f -> g) (o -> i) -> i -> f -> Either e g 72 | set l v = runKleisli (Poly.set l . arr (v,)) 73 | 74 | -- | Embed a total lens that points to an `Either` field into a lens that might 75 | -- fail. 76 | 77 | embed :: Poly.Lens (->) (f -> g) (Either e o -> Either e i) -> Lens e (f -> g) (o -> i) 78 | embed l = lens (Poly.get l) (\m f -> const (Poly.modify l ((>>= m), f)) <$> Poly.get l f) 79 | 80 | ------------------------------------------------------------------------------- 81 | 82 | -- | Like 'modify' but return behaves like the identity function when the field 83 | -- could not be set. 84 | 85 | modify' :: Lens e (f -> f) (o -> o) -> (o -> o) -> f -> f 86 | modify' l m f = either (const f) id (modify l m f) 87 | 88 | -- | Like 'set' but return behaves like the identity function when the field 89 | -- could not be set. 90 | 91 | set' :: Lens e (f -> f) (o -> o) -> o -> f -> f 92 | set' l v f = either (const f) id (set l v f) 93 | 94 | -------------------------------------------------------------------------------- /src/Data/Label/Partial.hs: -------------------------------------------------------------------------------- 1 | {-| Monomorphic lenses where the getters and updates can potentially silently 2 | fail. Partial lenses are useful for creating accessor labels for multi 3 | constructor data types where projection and modification of fields will not 4 | always succeed. 5 | -} 6 | 7 | {-# LANGUAGE TypeOperators #-} 8 | module Data.Label.Partial 9 | ( (:~>) 10 | , Partial 11 | , lens 12 | , get 13 | , modify 14 | , set 15 | , embed 16 | 17 | -- * Seemingly total modifications. 18 | , set' 19 | , modify' 20 | 21 | -- * Potentially removing modification. 22 | , update 23 | ) 24 | where 25 | 26 | import Control.Applicative 27 | import Control.Arrow 28 | import Control.Category 29 | import Data.Label.Point (Partial) 30 | import Data.Label.Poly (Lens) 31 | import Data.Maybe 32 | import Prelude hiding ((.), id) 33 | 34 | import qualified Data.Label.Poly as Poly 35 | 36 | {-# INLINE lens #-} 37 | {-# INLINE get #-} 38 | {-# INLINE modify #-} 39 | {-# INLINE set #-} 40 | {-# INLINE embed #-} 41 | {-# INLINE set' #-} 42 | {-# INLINE modify' #-} 43 | 44 | -- | Partial lens type for situations in which the accessor functions can fail. 45 | 46 | type f :~> o = Lens Partial f o 47 | 48 | ------------------------------------------------------------------------------- 49 | 50 | -- | Create a lens that can fail from a getter and a modifier that can 51 | -- themselves potentially fail. 52 | 53 | lens :: (f -> Maybe o) -- ^ Getter. 54 | -> ((o -> Maybe i) -> f -> Maybe g) -- ^ Modifier. 55 | -> (f -> g) :~> (o -> i) 56 | lens g s = Poly.lens (Kleisli g) (Kleisli (\(m, f) -> s (runKleisli m) f)) 57 | 58 | -- | Getter for a lens that can fail. When the field to which the lens points 59 | -- is not accessible the getter returns 'Nothing'. 60 | 61 | get :: (f -> g) :~> (o -> i) -> f -> Maybe o 62 | get l = runKleisli (Poly.get l) 63 | 64 | -- | Modifier for a lens that can fail. When the field to which the lens points 65 | -- is not accessible this function returns 'Nothing'. 66 | 67 | modify :: (f -> g) :~> (o -> i) -> (o -> i) -> f -> Maybe g 68 | modify l m = runKleisli (Poly.modify l . arr ((,) (arr m))) 69 | 70 | -- | Setter for a lens that can fail. When the field to which the lens points 71 | -- is not accessible this function returns 'Nothing'. 72 | 73 | set :: (f -> g) :~> (o -> i) -> i -> f -> Maybe g 74 | set l v = runKleisli (Poly.set l . arr ((,) v)) 75 | 76 | -- | Embed a total lens that points to a `Maybe` field into a lens that might 77 | -- fail. 78 | 79 | embed :: Lens (->) (f -> g) (Maybe o -> Maybe i) -> (f -> g) :~> (o -> i) 80 | embed l = lens (Poly.get l) (\m f -> const (Poly.modify l ((>>= m), f)) <$> Poly.get l f) 81 | 82 | ------------------------------------------------------------------------------- 83 | 84 | -- | Like 'modify' but return behaves like the identity function when the field 85 | -- could not be set. 86 | 87 | modify' :: (f -> f) :~> (o -> o) -> (o -> o) -> f -> f 88 | modify' l m f = f `fromMaybe` modify l m f 89 | 90 | -- | Like 'set' but return behaves like the identity function when the field 91 | -- could not be set. 92 | 93 | set' :: (f -> f) :~> (o -> o) -> o -> f -> f 94 | set' l v f = f `fromMaybe` set l v f 95 | 96 | -- | Like `modify`, but update allows, depending on the underlying lens, to 97 | -- remove items by modifying to `Nothing`. 98 | 99 | update :: (f -> b) :~> (o -> i) -> (o -> Maybe i) -> f -> Maybe b 100 | update l m = runKleisli (Poly.modify l . arr ((,) (Kleisli m))) 101 | 102 | -------------------------------------------------------------------------------- /src/Data/Label/Base.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Labels for data types in the base package. The lens types are kept abstract to 3 | be fully reusable in custom contexts. Build to be imported qualified. 4 | -} 5 | 6 | {-# LANGUAGE 7 | NoMonomorphismRestriction 8 | , TemplateHaskell 9 | , TypeOperators 10 | #-} 11 | 12 | module Data.Label.Base 13 | ( 14 | -- * Lenses for lists. 15 | head 16 | , tail 17 | 18 | -- * Lenses for Either. 19 | , left 20 | , right 21 | 22 | -- * Lens for Maybe. 23 | , just 24 | 25 | -- * Lenses for 2-tuples. 26 | , fst 27 | , snd 28 | , swap 29 | 30 | -- * Lenses for 3-tuples. 31 | , fst3 32 | , snd3 33 | , trd3 34 | 35 | -- * Read/Show isomorphism. 36 | , readShow 37 | ) 38 | where 39 | 40 | import Prelude hiding (fst, snd, head, tail) 41 | import Control.Arrow (arr, Kleisli(..), ArrowApply, ArrowZero, ArrowChoice) 42 | import Data.Maybe (listToMaybe) 43 | import Data.Label.Partial (Partial) 44 | import Data.Label 45 | 46 | import qualified Data.Label.Mono as Mono 47 | import qualified Data.Label.Poly as Poly 48 | import qualified Data.Tuple as Tuple 49 | 50 | -- | Lens pointing to the head of a list's cons cell. (Partial and monomorphic) 51 | 52 | head :: (ArrowZero arr, ArrowApply arr, ArrowChoice arr) 53 | => Mono.Lens arr [a] a 54 | 55 | -- | Lens pointing to the tail of a list's cons cell. (Partial and monomorphic) 56 | 57 | tail :: (ArrowZero arr, ArrowApply arr, ArrowChoice arr) 58 | => Mono.Lens arr [a] [a] 59 | 60 | (head, tail) = $(getLabel ''[]) 61 | 62 | -- | Lens pointing to the left value in an Either. (Partial and polymorphic) 63 | 64 | left :: (ArrowZero arr, ArrowApply arr, ArrowChoice arr) 65 | => Poly.Lens arr (Either a b -> Either o b) (a -> o) 66 | 67 | -- | Lens pointing to the right value in an Either. (Partial and polymorphic) 68 | 69 | right :: (ArrowZero arr, ArrowApply arr, ArrowChoice arr) 70 | => Poly.Lens arr (Either a b -> Either a o) (b -> o) 71 | 72 | (left, right) = $(getLabel ''Either) 73 | 74 | -- | Lens pointing to the value in a Maybe. (Partial and polymorphic) 75 | 76 | just :: (ArrowChoice cat, ArrowZero cat, ArrowApply cat) 77 | => Poly.Lens cat (Maybe a -> Maybe b) (a -> b) 78 | 79 | just = $(getLabel ''Maybe) 80 | 81 | -- | Lens pointing to the first component of a 2-tuple. (Total and polymorphic) 82 | 83 | fst :: ArrowApply arr => Poly.Lens arr ((a, b) -> (o, b)) (a -> o) 84 | 85 | -- | Lens pointing to the second component of a 2-tuple. (Total and polymorphic) 86 | 87 | snd :: ArrowApply arr => Poly.Lens arr ((a, b) -> (a, o)) (b -> o) 88 | 89 | (fst, snd) = $(getLabel ''(,)) 90 | 91 | -- | Polymorphic lens that swaps the components of a tuple. (Total and polymorphic) 92 | 93 | swap :: ArrowApply arr => Poly.Lens arr ((a, b) -> (c, d)) ((b, a) -> (d, c)) 94 | swap = let io = Iso (arr Tuple.swap) (arr Tuple.swap) in Poly.iso io io 95 | 96 | -- | Lens pointing to the first component of a 3-tuple. (Total and polymorphic) 97 | 98 | fst3 :: ArrowApply arr => Poly.Lens arr ((a, b, c) -> (o, b, c)) (a -> o) 99 | 100 | -- | Lens pointing to the second component of a 3-tuple. (Total and polymorphic) 101 | 102 | snd3 :: ArrowApply arr => Poly.Lens arr ((a, b, c) -> (a, o, c)) (b -> o) 103 | 104 | -- | Lens pointing to the third component of a 3-tuple. (Total and polymorphic) 105 | 106 | trd3 :: ArrowApply arr => Poly.Lens arr ((a, b, c) -> (a, b, o)) (c -> o) 107 | 108 | (fst3, snd3, trd3) = $(getLabel ''(,,)) 109 | 110 | -- | Partial isomorphism for readable and showable values. Can easily be lifted 111 | -- into a lens by using `iso`. 112 | 113 | readShow :: (Read a, Show a) => Iso Partial String a 114 | readShow = Iso r s 115 | where r = Kleisli (fmap Tuple.fst . listToMaybe . readsPrec 0) 116 | s = arr show 117 | 118 | -------------------------------------------------------------------------------- /src/Data/Label/Poly.hs: -------------------------------------------------------------------------------- 1 | {- | Lenses that allow polymorphic updates. -} 2 | 3 | {-# LANGUAGE 4 | FlexibleInstances 5 | , GADTs 6 | , MultiParamTypeClasses 7 | , TypeOperators #-} 8 | 9 | module Data.Label.Poly 10 | ( 11 | 12 | -- * The polymorphic Lens type. 13 | Lens 14 | , lens 15 | , point 16 | , get 17 | , modify 18 | , set 19 | , iso 20 | , (>-) 21 | , for 22 | ) 23 | where 24 | 25 | import Control.Category 26 | import Control.Arrow 27 | import Prelude () 28 | import Data.Label.Point (Point (Point), Iso(..), identity, compose) 29 | 30 | import qualified Data.Label.Point as Point 31 | 32 | {-# INLINE lens #-} 33 | {-# INLINE get #-} 34 | {-# INLINE modify #-} 35 | {-# INLINE set #-} 36 | {-# INLINE (>-) #-} 37 | {-# INLINE point #-} 38 | {-# INLINE unpack #-} 39 | 40 | ------------------------------------------------------------------------------- 41 | 42 | -- | Abstract polymorphic lens datatype. The getter and setter functions work 43 | -- in some category. Categories allow for effectful lenses, for example, lenses 44 | -- that might fail or use state. 45 | 46 | data Lens cat f o where 47 | Lens :: !(Point cat g i f o) -> Lens cat (f -> g) (o -> i) 48 | Id :: ArrowApply cat => Lens cat f f 49 | 50 | -- | Create a lens out of a getter and setter. 51 | 52 | lens :: cat f o -- ^ Getter. 53 | -> cat (cat o i, f) g -- ^ Modifier. 54 | -> Lens cat (f -> g) (o -> i) 55 | lens g m = Lens (Point g m) 56 | 57 | -- | Create lens from a `Point`. 58 | 59 | point :: Point cat g i f o -> Lens cat (f -> g) (o -> i) 60 | point = Lens 61 | 62 | -- | Get the getter arrow from a lens. 63 | 64 | get :: Lens cat (f -> g) (o -> i) -> cat f o 65 | get = Point.get . unpack 66 | 67 | -- | Get the modifier arrow from a lens. 68 | 69 | modify :: Lens cat (f -> g) (o -> i) -> cat (cat o i, f) g 70 | modify = Point.modify . unpack 71 | 72 | -- | Get the setter arrow from a lens. 73 | 74 | set :: Arrow arr => Lens arr (f -> g) (o -> i) -> arr (i, f) g 75 | set = Point.set . unpack 76 | 77 | -- | Lift a polymorphic isomorphism into a `Lens`. 78 | -- 79 | -- The isomorphism needs to be passed in twice to properly unify. 80 | 81 | iso :: ArrowApply cat => Iso cat f o -> Iso cat g i -> Lens cat (f -> g) (o -> i) 82 | iso (Iso f _) (Iso _ y) = lens f (app . arr (\(m, v) -> (y . m . f, v))) 83 | 84 | ------------------------------------------------------------------------------- 85 | 86 | -- | Category instance for monomorphic lenses. 87 | 88 | instance ArrowApply arr => Category (Lens arr) where 89 | id = Id 90 | Lens f . Lens g = Lens (compose f g) 91 | Id . u = u 92 | u . Id = u 93 | {-# INLINE id #-} 94 | {-# INLINE (.) #-} 95 | 96 | -- | Make a Lens output diverge by changing the input of the modifier. The 97 | -- operator can be read as /points-to/. 98 | 99 | infix 7 >- 100 | 101 | (>-) :: Arrow arr => Lens arr (j -> a) (i -> b) -> Lens arr (f -> g) (o -> i) -> Point arr g j f o 102 | (>-) (Lens (Point f _)) (Lens l) = Point (Point.get l) (Point.modify l . first (arr (f .))) 103 | (>-) (Lens (Point f _)) Id = Point id (app . first (arr (f .))) 104 | (>-) Id l = unpack l 105 | 106 | -- | Non-operator version of `>-`, since it clashes with an operator 107 | -- when the Arrows language extension is used. 108 | 109 | infix 7 `for` 110 | 111 | for :: Arrow arr => Lens arr (j -> a) (i -> b) -> Lens arr (f -> g) (o -> i) -> Point arr g j f o 112 | for = (>-) 113 | 114 | ------------------------------------------------------------------------------- 115 | 116 | -- | Convert a polymorphic lens back to point. 117 | 118 | unpack :: Lens cat (f -> g) (o -> i) -> Point cat g i f o 119 | unpack Id = identity 120 | unpack (Lens p) = p 121 | 122 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # make_travis_yml_2.hs 'fclabels.cabal' 4 | # 5 | # For more information, see https://github.com/hvr/multi-ghc-travis 6 | # 7 | language: c 8 | sudo: false 9 | 10 | git: 11 | submodules: false # whether to recursively clone submodules 12 | 13 | cache: 14 | directories: 15 | - $HOME/.cabal/packages 16 | - $HOME/.cabal/store 17 | 18 | before_cache: 19 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 20 | # remove files that are regenerated by 'cabal update' 21 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 22 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 23 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 24 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 25 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 26 | 27 | matrix: 28 | include: 29 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 30 | - compiler: "ghc-8.8.1" 31 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-8.8.1], sources: [hvr-ghc]}} 32 | - compiler: "ghc-7.4.2" 33 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-7.4.2], sources: [hvr-ghc]}} 34 | - compiler: "ghc-8.6.5" 35 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-8.6.5], sources: [hvr-ghc]}} 36 | - compiler: "ghc-8.4.4" 37 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-8.4.4], sources: [hvr-ghc]}} 38 | - compiler: "ghc-8.2.2" 39 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-8.2.2], sources: [hvr-ghc]}} 40 | - compiler: "ghc-8.0.2" 41 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-8.0.2], sources: [hvr-ghc]}} 42 | - compiler: "ghc-7.10.3" 43 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-7.10.3], sources: [hvr-ghc]}} 44 | - compiler: "ghc-7.8.4" 45 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-7.8.4], sources: [hvr-ghc]}} 46 | - compiler: "ghc-7.6.3" 47 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-7.6.3], sources: [hvr-ghc]}} 48 | 49 | before_install: 50 | - HC=${CC} 51 | - unset CC 52 | - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH 53 | - PKGNAME='fclabels' 54 | 55 | install: 56 | - cabal --version 57 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 58 | - BENCH=${BENCH---enable-benchmarks} 59 | - TEST=${TEST---enable-tests} 60 | - travis_retry cabal update -v 61 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 62 | - rm -fv cabal.project.local 63 | - "echo 'packages: .' > cabal.project" 64 | - rm -f cabal.project.freeze 65 | - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all 66 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all 67 | 68 | # Here starts the actual work to be performed for the package under test; 69 | # any command which exits with a non-zero exit code causes the build to fail. 70 | script: 71 | - if [ -f configure.ac ]; then autoreconf -i; fi 72 | - rm -rf dist-newstyle 73 | - cabal sdist # test that a source-distribution can be generated 74 | - cd dist-newstyle/sdist 75 | - SRCTAR=(${PKGNAME}-*.tar.gz) 76 | - SRC_BASENAME="${SRCTAR/%.tar.gz}" 77 | - tar -xvf "./$SRC_BASENAME.tar.gz" 78 | - cd "$SRC_BASENAME/" 79 | ## from here on, CWD is inside the extracted source-tarball 80 | - rm -fv cabal.project.local 81 | - "echo 'packages: .' > cabal.project" 82 | # this builds all libraries and executables (without tests/benchmarks) 83 | - rm -f cabal.project.freeze 84 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all 85 | # this builds all libraries and executables (including tests/benchmarks) 86 | # - rm -rf ./dist-newstyle 87 | 88 | # build & run tests 89 | - cabal new-build -w ${HC} ${TEST} ${BENCH} all 90 | - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi 91 | 92 | # EOF 93 | -------------------------------------------------------------------------------- /fclabels.cabal: -------------------------------------------------------------------------------- 1 | Name: fclabels 2 | Version: 2.0.5.1 3 | Author: Sebastiaan Visser, Erik Hesselink, Chris Eidhof, Sjoerd Visscher 4 | with lots of help and feedback from others. 5 | Synopsis: First class accessor labels implemented as lenses. 6 | Description: This package provides first class labels that can act as 7 | bidirectional record fields. The labels can be derived 8 | automatically using Template Haskell which means you don't have 9 | to write any boilerplate yourself. The labels are implemented as 10 | /lenses/ and are fully composable. Lenses can be used to /get/, 11 | /set/ and /modify/ parts of a data type in a consistent way. 12 | . 13 | See "Data.Label" for an introductory explanation or see the 14 | introductory blog post at 15 | 16 | . 17 | * /Total and partial lenses/ 18 | . 19 | Internally lenses do not used Haskell functions directly, but 20 | are implemented as categories. Categories allow the lenses to be 21 | run in custom computational contexts. This approach allows us to 22 | make partial lenses that point to fields of multi-constructor 23 | datatypes in an elegant way. 24 | . 25 | See "Data.Label.Partial" for the use of partial labels. 26 | . 27 | * /Monomorphic and polymorphic lenses/ 28 | . 29 | We have both polymorphic and monomorphic lenses. Polymorphic 30 | lenses allow updates that change the type. The types of 31 | polymorphic lenses are slightly more verbose than their 32 | monomorphic counterparts, but their usage is similar. Because 33 | monomorphic lenses are built by restricting the types of 34 | polymorphic lenses they are essentially the same and can be 35 | freely composed with eachother. 36 | . 37 | See "Data.Label.Mono" and "Data.Label.Poly" for the difference 38 | between polymorphic and monomorphic lenses. 39 | . 40 | * /Using fclabels/ 41 | . 42 | To simplify working with labels we supply both a set of labels 43 | for Haskell's base types, like lists, tuples, Maybe and Either, 44 | and we supply a set of combinators for working with labels for 45 | values in the Reader and State monad. 46 | . 47 | See "Data.Label.Base" and "Data.Label.Monadic" for more 48 | information. 49 | . 50 | * /Changelog from 2.0.4 to 2.0.5/ 51 | . 52 | > - Support for GHC 8.10. Thanks to Potato Hatsue. 53 | 54 | Maintainer: Sebastiaan Visser 55 | Homepage: https://github.com/sebastiaanvisser/fclabels 56 | Bug-Reports: https://github.com/sebastiaanvisser/fclabels/issues 57 | License: BSD3 58 | License-File: LICENSE 59 | Category: Data, Lenses 60 | Cabal-Version: >= 1.10 61 | Build-Type: Simple 62 | Tested-With: 63 | GHC==7.4.2, 64 | GHC==7.6.3, 65 | GHC==7.8.4, 66 | GHC==7.10.3, 67 | GHC==8.0.2 68 | Extra-Source-Files: 69 | README.md 70 | CHANGELOG 71 | 72 | Library 73 | HS-Source-Dirs: src 74 | 75 | Exposed-Modules: 76 | Data.Label 77 | Data.Label.Base 78 | Data.Label.Derive 79 | Data.Label.Failing 80 | Data.Label.Monadic 81 | Data.Label.Mono 82 | Data.Label.Partial 83 | Data.Label.Point 84 | Data.Label.Poly 85 | Data.Label.Total 86 | 87 | GHC-Options: -Wall 88 | Build-Depends: 89 | base >= 4.5 && < 5 90 | , base-orphans >= 0.8.2 && < 0.10 91 | , template-haskell >= 2.2 && < 2.24 92 | , mtl >= 1.0 && < 2.4 93 | , transformers >= 0.2 && < 0.7 94 | 95 | Default-Language: Haskell2010 96 | 97 | Source-Repository head 98 | Type: git 99 | Location: git://github.com/sebastiaanvisser/fclabels.git 100 | 101 | Test-Suite suite 102 | Type: exitcode-stdio-1.0 103 | HS-Source-Dirs: test 104 | Main-Is: TestSuite.hs 105 | Ghc-Options: -Wall -threaded 106 | Build-Depends: 107 | base < 5 108 | , fclabels 109 | , template-haskell 110 | , mtl 111 | , transformers 112 | , HUnit >= 1.2 && < 1.7 113 | Default-Language: Haskell2010 114 | 115 | Benchmark benchmark 116 | Type: exitcode-stdio-1.0 117 | HS-Source-Dirs: bench 118 | Main-Is: Benchmark.hs 119 | Ghc-Options: -Wall -threaded 120 | Build-Depends: 121 | base < 5 122 | , fclabels 123 | , criterion < 1.6 124 | Default-Language: Haskell2010 125 | -------------------------------------------------------------------------------- /src/Data/Label/Point.hs: -------------------------------------------------------------------------------- 1 | {- | The Point data type which generalizes the different lenses and forms the 2 | basis for vertical composition using the `Applicative` type class. 3 | -} 4 | 5 | {-# LANGUAGE 6 | TypeOperators 7 | , Arrows 8 | , FlexibleInstances 9 | , MultiParamTypeClasses 10 | , TypeSynonymInstances #-} 11 | 12 | module Data.Label.Point 13 | ( 14 | -- * The point data type that generalizes lens. 15 | Point (Point) 16 | , get 17 | , modify 18 | , set 19 | , identity 20 | , compose 21 | 22 | -- * Working with isomorphisms. 23 | , Iso (..) 24 | , inv 25 | 26 | -- * Specialized lens contexts. 27 | , Total 28 | , Partial 29 | , Failing 30 | 31 | -- * Arrow type class for failing with some error. 32 | , ArrowFail (..) 33 | ) 34 | where 35 | 36 | import Control.Arrow 37 | import Control.Applicative 38 | import Control.Category 39 | import Data.Orphans () 40 | import Prelude hiding ((.), id, const, curry, uncurry) 41 | 42 | {-# INLINE get #-} 43 | {-# INLINE modify #-} 44 | {-# INLINE set #-} 45 | {-# INLINE identity #-} 46 | {-# INLINE compose #-} 47 | {-# INLINE inv #-} 48 | {-# INLINE const #-} 49 | {-# INLINE curry #-} 50 | 51 | ------------------------------------------------------------------------------- 52 | 53 | -- | Abstract Point datatype. The getter and modifier operations work in some 54 | -- category. The type of the value pointed to might change, thereby changing 55 | -- the type of the outer structure. 56 | 57 | data Point cat g i f o = Point (cat f o) (cat (cat o i, f) g) 58 | 59 | -- | Get the getter category from a Point. 60 | 61 | get :: Point cat g i f o -> cat f o 62 | get (Point g _) = g 63 | 64 | -- | Get the modifier category from a Point. 65 | 66 | modify :: Point cat g i f o -> cat (cat o i, f) g 67 | modify (Point _ m) = m 68 | 69 | -- | Get the setter category from a Point. 70 | 71 | set :: Arrow arr => Point arr g i f o -> arr (i, f) g 72 | set p = modify p . first (arr const) 73 | 74 | -- | Identity Point. Cannot change the type. 75 | 76 | identity :: ArrowApply arr => Point arr f f o o 77 | identity = Point id app 78 | 79 | -- | Point composition. 80 | 81 | compose :: ArrowApply cat 82 | => Point cat t i b o 83 | -> Point cat g t f b 84 | -> Point cat g i f o 85 | compose (Point f m) (Point g n) 86 | = Point (f . g) (uncurry (curry n . curry m)) 87 | 88 | ------------------------------------------------------------------------------- 89 | 90 | instance Arrow arr => Functor (Point arr f i f) where 91 | fmap f x = pure f <*> x 92 | {-# INLINE fmap #-} 93 | 94 | instance Arrow arr => Applicative (Point arr f i f) where 95 | pure a = Point (const a) (arr snd) 96 | a <*> b = Point (arr app . (get a &&& get b)) $ 97 | proc (t, p) -> do (f, v) <- get a &&& get b -< p 98 | q <- modify a -< (t . arr ($ v), p) 99 | modify b -< (t . arr f, q) 100 | {-# INLINE pure #-} 101 | {-# INLINE (<*>) #-} 102 | 103 | instance Alternative (Point Partial f view f) where 104 | empty = Point zeroArrow zeroArrow 105 | Point a b <|> Point c d = Point (a <|> c) (b <|> d) 106 | 107 | ------------------------------------------------------------------------------- 108 | 109 | infix 8 `Iso` 110 | 111 | -- | An isomorphism is like a `Category` that works in two directions. 112 | 113 | data Iso cat i o = Iso { fw :: cat i o, bw :: cat o i } 114 | 115 | -- | Isomorphisms are categories. 116 | 117 | instance Category cat => Category (Iso cat) where 118 | id = Iso id id 119 | Iso a b . Iso c d = Iso (a . c) (d . b) 120 | {-# INLINE id #-} 121 | {-# INLINE (.) #-} 122 | 123 | -- | Flip an isomorphism. 124 | 125 | inv :: Iso cat i o -> Iso cat o i 126 | inv i = Iso (bw i) (fw i) 127 | 128 | ------------------------------------------------------------------------------- 129 | 130 | -- | Context that represents computations that always produce an output. 131 | 132 | type Total = (->) 133 | 134 | -- | Context that represents computations that might silently fail. 135 | 136 | type Partial = Kleisli Maybe 137 | 138 | -- | Context that represents computations that might fail with some error. 139 | 140 | type Failing e = Kleisli (Either e) 141 | 142 | -- | The ArrowFail class is similar to `ArrowZero`, but additionally embeds 143 | -- some error value in the computation instead of throwing it away. 144 | 145 | class Arrow a => ArrowFail e a where 146 | failArrow :: a e c 147 | 148 | instance ArrowFail e Partial where 149 | failArrow = Kleisli (const Nothing) 150 | {-# INLINE failArrow #-} 151 | 152 | instance ArrowFail e (Failing e) where 153 | failArrow = Kleisli Left 154 | {-# INLINE failArrow #-} 155 | 156 | ------------------------------------------------------------------------------- 157 | -- Common operations experessed in a generalized form. 158 | 159 | const :: Arrow arr => c -> arr b c 160 | const a = arr (\_ -> a) 161 | 162 | curry :: Arrow cat => cat (a, b) c -> (a -> cat b c) 163 | curry m i = m . (const i &&& id) 164 | 165 | uncurry :: ArrowApply cat => (a -> cat b c) -> cat (a, b) c 166 | uncurry a = app . arr (first a) 167 | 168 | -------------------------------------------------------------------------------- /src/Data/Label.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {- | 3 | This package provides first class labels that can act as bidirectional record 4 | fields. The labels can be derived automatically using Template Haskell which 5 | means you don't have to write any boilerplate yourself. The labels are 6 | implemented as lenses and are fully composable. Labels can be used to /get/, 7 | /set/ and /modify/ parts of a datatype in a consistent way. 8 | -} 9 | 10 | module Data.Label 11 | ( 12 | 13 | -- * Working with @fclabels@. 14 | 15 | {- | 16 | The lens datatype, conveniently called `:->', is an instance of the 17 | "Control.Category" type class: meaning it has a proper identity and 18 | composition. The library has support for automatically deriving labels from 19 | record selectors that start with an underscore. 20 | 21 | To illustrate this package, let's take the following two example datatypes. 22 | -} 23 | 24 | -- | 25 | -- >{-# LANGUAGE TemplateHaskell, TypeOperators #-} 26 | -- >import Control.Category 27 | -- >import Data.Label 28 | -- >import Prelude hiding ((.), id) 29 | -- > 30 | -- >data Person = Person 31 | -- > { _name :: String 32 | -- > , _age :: Int 33 | -- > , _place :: Place 34 | -- > } deriving Show 35 | -- > 36 | -- >data Place = Place 37 | -- > { _city 38 | -- > , _country 39 | -- > , _continent :: String 40 | -- > } deriving Show 41 | 42 | {- | 43 | Both datatypes are record types with all the labels prefixed with an 44 | underscore. This underscore is an indication for our Template Haskell code to 45 | derive lenses for these fields. Deriving lenses can be done with this simple 46 | one-liner: 47 | 48 | >mkLabels [''Person, ''Place] 49 | 50 | For all labels a lens will created. 51 | 52 | Now let's look at this example. This 71 year old fellow, my neighbour called 53 | Jan, didn't mind using him as an example: 54 | 55 | >jan :: Person 56 | >jan = Person "Jan" 71 (Place "Utrecht" "The Netherlands" "Europe") 57 | 58 | When we want to be sure Jan is really as old as he claims we can use the `get` 59 | function to get the age out as an integer: 60 | 61 | >hisAge :: Int 62 | >hisAge = get age jan 63 | 64 | Consider he now wants to move to Amsterdam: what better place to spend your old 65 | days. Using composition we can change the city value deep inside the structure: 66 | 67 | >moveToAmsterdam :: Person -> Person 68 | >moveToAmsterdam = set (city . place) "Amsterdam" 69 | 70 | And now: 71 | 72 | >ghci> moveToAmsterdam jan 73 | >Person "Jan" 71 (Place "Amsterdam" "The Netherlands" "Europe") 74 | 75 | Composition is done using the @(`.`)@ operator which is part of the 76 | "Control.Category" module. Make sure to import this module and hide the default 77 | @(`.`)@, `id` function from the Haskell "Prelude". 78 | 79 | -} 80 | 81 | -- * Total monomorphic lenses. 82 | 83 | (:->) 84 | , lens 85 | , get 86 | , set 87 | , modify 88 | 89 | -- * Vertical composition using @Applicative@. 90 | 91 | {- | 92 | 93 | Now, because Jan is an old guy, moving to another city is not a very easy task, 94 | this really takes a while. It will probably take no less than two years before 95 | he will actually be settled. To reflect this change it might be useful to have 96 | a first class view on the `Person` datatype that only reveals the age and 97 | city. This can be done by using a neat `Applicative` functor instance: 98 | 99 | >import Control.Applicative 100 | 101 | >(fstL, sndL) = $(getLabel ''(,)) 102 | 103 | >ageAndCity :: Person :-> (Int, String) 104 | >ageAndCity = point $ 105 | > (,) <$> fstL >- age 106 | > <*> sndL >- city . place 107 | 108 | Because the applicative type class on its own is not capable of expressing 109 | bidirectional relations, which we need for our lenses, the actual instance is 110 | defined for an internal helper structure called `Point`. Points are a more 111 | general than lenses. As you can see above, the `point` function has to be 112 | used to convert a `Point` back into a `Lens`. The (`>-`) operator is used to 113 | indicate which partial destructor to use per arm of the applicative 114 | composition. 115 | 116 | Now that we have an appropriate age+city view on the `Person` datatype (which 117 | is itself a lens again), we can use the `modify` function to make Jan move to 118 | Amsterdam over exactly two years: 119 | 120 | >moveToAmsterdamOverTwoYears :: Person -> Person 121 | >moveToAmsterdamOverTwoYears = modify ageAndCity (\(a, _) -> (a+2, "Amsterdam")) 122 | 123 | >ghci> moveToAmsterdamOverTwoYears jan 124 | >Person "Jan" 73 True (Place "Amsterdam" "The Netherlands" "Europe") 125 | 126 | -} 127 | 128 | , point 129 | , (>-) 130 | , for 131 | 132 | -- * Working with isomorphisms. 133 | -- 134 | -- | This package contains an isomorphisms datatype that encodes bidirectional 135 | -- functions, or better bidirectional categories. Just like lenses, 136 | -- isomorphisms can be composed using the `Category` type class. Isomorphisms 137 | -- can be used to change the type of a lens. Every isomorphism can be lifted 138 | -- into a lens. 139 | -- 140 | -- For example, when we want to treat the age of a person as a string we can do 141 | -- the following: 142 | -- 143 | -- > ageAsString :: Person :-> String 144 | -- > ageAsString = iso (Iso show read) . age 145 | 146 | , Iso (..) 147 | , inv 148 | , iso 149 | 150 | -- * Derive labels using Template Haskell. 151 | -- 152 | -- | Template Haskell functions for automatically generating labels for 153 | -- algebraic datatypes, newtypes and GADTs. There are two basic modes of label 154 | -- generation, the `mkLabels` family of functions create labels (and optionally 155 | -- type signatures) in scope as top level funtions, the `getLabel` family of 156 | -- funtions create labels as expressions that can be named and typed manually. 157 | -- 158 | -- In the case of multi-constructor datatypes some fields might not always be 159 | -- available and the derived labels will be partial. Partial labels are 160 | -- provided with an additional type context that forces them to be only usable 161 | -- in the `Partial' or `Failing` context. 162 | -- 163 | -- More derivation functions can be found in "Data.Label.Derive". 164 | 165 | , mkLabel 166 | , mkLabels 167 | , getLabel 168 | , fclabels 169 | ) 170 | where 171 | 172 | import Data.Label.Point (Iso(..), inv) 173 | import Data.Label.Poly (point, (>-), for) 174 | import Data.Label.Mono (iso, (:->)) 175 | import Data.Label.Derive (mkLabel, mkLabels, getLabel, fclabels) 176 | 177 | import qualified Data.Label.Mono as Mono 178 | 179 | {-# INLINE lens #-} 180 | {-# INLINE get #-} 181 | {-# INLINE modify #-} 182 | {-# INLINE set #-} 183 | 184 | ------------------------------------------------------------------------------- 185 | 186 | -- | Create a total lens from a getter and a modifier. 187 | -- 188 | -- We expect the following law to hold: 189 | -- 190 | -- > get l (modify l m f) == m (get l f) 191 | 192 | lens :: (f -> a) -- ^ Getter. 193 | -> ((a -> a) -> f -> f) -- ^ Modifier. 194 | -> f :-> a 195 | lens g s = Mono.lens g (uncurry s) 196 | 197 | -- | Get the getter function from a lens. 198 | 199 | get :: (f :-> a) -> f -> a 200 | get = Mono.get 201 | 202 | -- | Get the modifier function from a lens. 203 | 204 | modify :: f :-> a -> (a -> a) -> f -> f 205 | modify = curry . Mono.modify 206 | 207 | -- | Get the setter function from a lens. 208 | 209 | set :: (f :-> a) -> a -> f -> f 210 | set = curry . Mono.set 211 | 212 | -------------------------------------------------------------------------------- /CHANGELOG: -------------------------------------------------------------------------------- 1 | CHANGELOG 2 | 3 | 2.0.5.1 4 | - Support for GHC 9.0. Thanks to Evan Laforge. 5 | 6 | 2.0.5 7 | - Support for GHC 8.10. Thanks to Potato Hatsue. 8 | 9 | 2.0.4 10 | - Import Functor, Applicative, and Monad instances for Kleisli from the 11 | base-orphans package for future GHC 8.10 support. 12 | 13 | 2.0.3.3 14 | 15 | - Allow GHC 8.4 pre-releases. 16 | 17 | 2.0.3.2 18 | 19 | - Allow HUnit 1.5.* 20 | 21 | 2.0.3.1 22 | 23 | - Allow HUnit 1.4.*. 24 | - Fix test suite on GHC 7.4. 25 | 26 | 2.0.3 27 | 28 | - Support GHC 8. 29 | 30 | 2.0.2.3 to 2.0.2.4 31 | 32 | - Allow transformers 0.5.*. 33 | 34 | 2.0.2.2 to 2.0.2.3 35 | 36 | - Allow HUnit 1.3.* 37 | 38 | 2.0.2.1 to 2.0.2.2 39 | 40 | - Restored support for GHC 7.4. 41 | 42 | 2.0.2 to 2.0.2.1 43 | 44 | - Support for GHC 7.10 by widening TH dependencies. 45 | 46 | 2.0.2 47 | - Add `for` as a synonym for `>-` to avoid a clash with the Arrows extension. 48 | 49 | 2.0.1.1 50 | 51 | - Allow mtl 2.2.* and transformers 0.4.* 52 | - Allow template-haskell 2.9.* in test-suite 53 | 54 | 2.0.0.5 to 2.0.1 55 | 56 | - Widened TH dependencies. 57 | 58 | 2.0.0.4 -> 2.0.0.5 59 | - Add Bug-Reports url again. 60 | 61 | 2.0.0.3 -> 2.0.0.4 62 | - Include CHANGELOG in source distribution. 63 | 64 | 2.0.0.2 -> 2.0.0.3 65 | - Support GHC 7.0. Note that there seems to be a problem with the 66 | appicative syntax, see test cases. 67 | 68 | 2.0.0.1 -> 2.0.0.2 69 | - Fix deriving with data types with more than 24 fields. 70 | 71 | 2.0 -> 2.0.0.1 72 | - Remove warnings on generated labels with OverloadedStrings. 73 | 74 | 1.1.7.1 -> 2.0 75 | 76 | - Introduced polymorphic lenses. 77 | - Lenses are now based on getters and modifiers, not getters and setters. 78 | - Pure lenses are now named Total lenses. 79 | - Maybe lenses are now named Partial lenses. 80 | - Introduced Failing lenses that preserve errors. 81 | - Generalized Point datatype. 82 | - Removed unused monadic functions for partial lenses. 83 | - Added ArrowFail type class. 84 | - Added lenses for base types. (tuples, lists, Maybe, Either) 85 | - Isomorphisms now uses regular function space for base morphism. 86 | - Swapped iso for more useful inv. 87 | - Introduced iso to more easily lift isomorphisms into lenses. 88 | - Removed mainly unused bimap. 89 | - Added derivation of lenses as expressions. 90 | - Convert record declarations directly into fclabels variants. 91 | - Allow deriving lenses for GADTs. 92 | - Added reasonably sophisticated totality checker for GADT labels. 93 | - Derived lenses can now fail in either ArrowZero or ArrowFail. 94 | - Alternative instance for Point. 95 | - Vertical composition for multi-constructor data types. 96 | - Extensive test suite. 97 | - Fully documented. 98 | 99 | 1.1.7 -> 1.1.7.1 100 | 101 | - Removed unicode from cabal file to help messed up build servers. 102 | 103 | 1.1.6 -> 1.1.7 104 | 105 | - Fixed compilation issue on newer GHC using clang. 106 | Thanks to 唐鳳. 107 | 108 | 1.1.5 -> 1.1.6 109 | 110 | - Exposed generic TH derive function. 111 | Thanks to Bram Schuur. 112 | 113 | 1.1.4.3 -> 1.1.5 114 | 115 | - Added `modifyAndGet` helper function. 116 | Thanks to Nikita Volkov. 117 | 118 | 1.1.4.2 -> 1.1.4.3 119 | 120 | - Make compilable against Template Haskell 2.8. 121 | Thanks to mgsloan for the pull request. 122 | - Added TH derivation support for special kinded type variables. 123 | 124 | 1.1.4 -> 1.1.4.2 125 | 126 | - Make compilable against Template Haskell 2.8. 127 | Thanks to Shimuuar for the pull request. 128 | 129 | 1.1.4 -> 1.1.4.1 130 | 131 | - Changed infix type variables to named type variables. 132 | This makes fclabels compile with GHC > 7.6. 133 | - Added the `osi` (flipped iso) again. 134 | 135 | 1.1.3 -> 1.1.4 136 | 137 | - Added function to derive labels for a single datatype. 138 | 139 | 1.1.1.0 -> 1.1.2 140 | 141 | - Added partial set/modify versions that act as identity when the 142 | constructor field is not available. 143 | 144 | 1.1.1.0 -> 1.1.1.1 145 | 146 | - Relax dependency on transformers to include 0.3.0.0. 147 | 148 | 1.1.0.2 -> 1.1.1.0 149 | 150 | - Added mkLabelsWith function to derive labels with custom names. 151 | Thanks to Evan Laforge for the patch! 152 | 153 | 1.1.0.1 -> 1.1.0.2 154 | 155 | - Fixed bug in `id` definition for `Lens (~>)`. 156 | Thanks to yczhang89 for reporting! 157 | 158 | 1.1.0 -> 1.1.0.1 159 | 160 | - Relax constraint on Template Haskell for GHC 7.4. 161 | 162 | 1.0.4 -> 1.1.0 163 | 164 | - Fixed error in derived code in combination with -XMonoLocalBinds. 165 | - Lowered the priority of =: operator. 166 | - Added the =. operator for modification in state monads. 167 | 168 | 1.0.4 -> 1.0.5 169 | 170 | - Relaxed Template Haskell dependency constraint for GHC 7.4 171 | - Relaxed transformers dependency constraint 172 | Thanks to Claude Heiland-Allen 173 | 174 | 1.0.3 -> 1.0.4 175 | 176 | - Bugfix to compile on GHC 6.12 again. 177 | 178 | 1.0.2 -> 1.0.3 179 | 180 | - Deriving labels for datatypes from other modules now works also when 181 | imported qualified. 182 | 183 | 1.0.1 -> 1.0.2 184 | 185 | - Allow generating monomorphic labels. 186 | - Prettify type variables in TH-derived code. 187 | 188 | 1.0 -> 1.0.1 189 | 190 | - Some documentation cleanups. 191 | - Major performance improvements in setting and modifying values by 192 | inlining most label functions. 193 | Thanks to Anpheus for benchmarking! 194 | 195 | 0.11.2 -> 1.0 196 | - Added abstract arrow based core module. 197 | - Allow both pure and failing labels to be derived. 198 | - Major API and documentation cleanup. 199 | - Renamed lots of exposed function names. 200 | 201 | 0.11.1.1 -> 0.11.2 202 | 203 | - Relaxed Template Haskell dependency constraint for GHC 7.2 204 | - Removed redundant import warnings. 205 | 206 | 0.11.1 -> 0.11.1.1 207 | 208 | - Improved TH support for multiple constructor datatypes. 209 | 210 | 0.9.1 -> 0.11.0 211 | 212 | - Monadic labels now build against mtl. 213 | - Separate module for core/non-core code. 214 | - Code cleanups, especially the TH code. 215 | 216 | 0.4.2 -> 0.9.1 217 | 218 | - Added askM and localM for running lenses inside MonadReader. 219 | - Minor documentaion update. 220 | - Exported Point internals. 221 | - Renamed Label to Lens. 222 | 223 | 0.9.1 -> 0.11.0 224 | 225 | - Monadic labels now build against mtl. 226 | - Separate module for core/non-core code. 227 | - Code cleanups, especially the TH code. 228 | 229 | 0.4.2 -> 0.9.1 230 | 231 | - Added askM and localM for running lenses inside MonadReader. 232 | - Minor documentaion update. 233 | - Exported Point internals. 234 | - Renamed Lens to Bijection, which is more correct. 235 | - Renamed Label to Lens. 236 | 237 | 0.4.2 -> 0.4.3 238 | 239 | - Added askM and locaM for running labels inside MonadReader. 240 | 241 | 0.4.2 -> 1.0.0 242 | 243 | - Added askM and localM for running lenses inside MonadReader. 244 | - Minor documentaion update. 245 | - Exported Point internals. 246 | - Renamed Lens to Bijection, which is more correct. 247 | - Renamed Label to Lens. 248 | 249 | 0.4.2 -> 0.4.3 250 | 251 | - Added askM and locaM for running labels inside MonadReader. 252 | - Minor documentaion update. 253 | - Exported Point internals. 254 | - Renamed Lens to Bijection, which is more correct. 255 | -------------------------------------------------------------------------------- /test/TestSuite.hs: -------------------------------------------------------------------------------- 1 | {- OPTIONS -ddump-splices #-} 2 | 3 | {-# LANGUAGE 4 | NoMonomorphismRestriction 5 | , KindSignatures 6 | , GADTs 7 | , TemplateHaskell 8 | , TypeOperators 9 | , RankNTypes 10 | , FlexibleContexts 11 | , FlexibleInstances 12 | , StandaloneDeriving 13 | , CPP #-} 14 | 15 | -- Needed for the Either String orphan instances. 16 | #if MIN_VERSION_transformers(0,5,0) && MIN_VERSION_base(4,9,0) 17 | {-# OPTIONS_GHC -Wno-orphans -Wno-warnings-deprecations #-} 18 | #endif 19 | 20 | module Main where 21 | 22 | import Control.Arrow 23 | import Control.Applicative 24 | import Control.Category 25 | #if MIN_VERSION_transformers(0,5,0) && MIN_VERSION_base(4,9,0) && !MIN_VERSION_mtl(2,3,0) 26 | import Control.Monad (MonadPlus (..)) 27 | import Control.Monad.Trans.Error (Error (noMsg)) 28 | #endif 29 | #if MIN_VERSION_mtl(2,3,0) 30 | import Control.Monad(MonadPlus (..)) 31 | #endif 32 | import Prelude hiding ((.), id) 33 | import Test.HUnit 34 | import Data.Label 35 | import Data.Label.Derive (defaultNaming, mkLabelsWith) 36 | import Data.Label.Mono ((:~>)) 37 | import Data.Label.Failing (Failing) 38 | import Data.Tuple (swap) 39 | 40 | import Control.Monad.Reader (runReader) 41 | import Control.Monad.State (evalState, execState, runState) 42 | 43 | import qualified Data.Label.Base as L 44 | import qualified Data.Label.Failing as Failing 45 | import qualified Data.Label.Mono as Mono 46 | import qualified Data.Label.Partial as Partial 47 | import qualified Data.Label.Poly as Poly 48 | import qualified Data.Label.Total as Total 49 | import qualified Data.Label.Monadic as Monadic 50 | 51 | ------------------------------------------------------------------------------- 52 | 53 | data NoRecord = NoRecord Integer Bool 54 | deriving (Eq, Ord, Show) 55 | 56 | mkLabel ''NoRecord 57 | 58 | fclabels [d| 59 | newtype Newtype a = Newtype { unNewtype :: [a] } 60 | |] 61 | 62 | deriving instance Eq a => Eq (Newtype a) 63 | deriving instance Ord a => Ord (Newtype a) 64 | deriving instance Show a => Show (Newtype a) 65 | 66 | newtypeL :: ArrowApply cat => Poly.Lens cat (Newtype a -> Newtype b) ([a] -> [b]) 67 | newtypeL = unNewtype 68 | 69 | data Record = Record 70 | { _fA :: Integer 71 | , _fB :: Maybe (Newtype Bool) 72 | , _fC :: Newtype Bool 73 | , _fD :: Either Integer Bool 74 | } deriving (Eq, Ord, Show) 75 | 76 | mkLabelsWith defaultNaming False False False False ''Record 77 | 78 | fD :: ArrowApply cat => Mono.Lens cat (Record) (Either Integer Bool) 79 | fC :: ArrowApply cat => Mono.Lens cat (Record) (Newtype Bool) 80 | fB :: ArrowApply cat => Mono.Lens cat (Record) (Maybe (Newtype Bool)) 81 | fA :: ArrowApply cat => Mono.Lens cat (Record) (Integer) 82 | 83 | data Multi 84 | = First { _mA :: Record 85 | , _mB :: Double 86 | , _mC :: Either String Float 87 | } 88 | | Second { _mB :: Double } 89 | deriving (Eq, Ord, Show) 90 | 91 | mkLabels [''Multi] 92 | 93 | data View = View 94 | { _vA :: Maybe (Newtype Bool) 95 | , _vB :: Either Integer Bool 96 | , _vC :: Newtype Bool 97 | } deriving (Eq, Ord, Show) 98 | 99 | mkLabelsWith defaultNaming True True False False ''View 100 | 101 | data Direction i a b c d 102 | = North { _dir :: i, _north :: a } 103 | | East { _dir :: i, _east :: b } 104 | | South { _dir :: i, _south :: c } 105 | | West { _dir :: i, _west :: d } 106 | | All { _dir :: i, _allDirs :: (a, b, c, d) } 107 | deriving (Eq, Ord, Show) 108 | 109 | mkLabelsWith defaultNaming True False True True ''Direction 110 | 111 | -- Higher kinded type variable, requires KindSignatures. 112 | 113 | data Fa f a = Fa { fa :: f a } 114 | 115 | mkLabel ''Fa 116 | 117 | ------------------------------------------------------------------------------- 118 | 119 | data Gadt a where 120 | C1 :: { ga :: Integer, gb :: Bool } -> Gadt (Int, Bool) 121 | C2 :: { gc :: Integer, gd :: Maybe Bool } -> Gadt Bool 122 | C3 :: { ge :: a, gf :: b } -> Gadt (a, b) 123 | C4 :: { gg :: a } -> Gadt [a] 124 | C5 :: { gd :: Maybe Bool } -> Gadt Bool 125 | C6 :: { gh :: [a] } -> Gadt (a, a, a) 126 | 127 | mkLabel ''Gadt 128 | 129 | _Ga :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Mono.Lens cat (Gadt (Int, Bool)) Integer 130 | _Gb :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Mono.Lens cat (Gadt (Int, Bool)) Bool 131 | _Gc :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Mono.Lens cat (Gadt Bool) Integer 132 | _Gd :: (ArrowApply cat ) => Mono.Lens cat (Gadt Bool) (Maybe Bool) 133 | _Ge :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt (a, b) -> Gadt (c, b)) (a -> c) 134 | _Gf :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt (a, b) -> Gadt (a, c)) (b -> c) 135 | _Gg :: (ArrowApply cat ) => Poly.Lens cat (Gadt [a] -> Gadt [b]) (a -> b) 136 | _Gh :: (ArrowApply cat ) => Poly.Lens cat (Gadt (a, a, a) -> Gadt (b, b, b)) ([a] -> [b]) 137 | 138 | _Ga = lGa; _Gb = lGb; _Gc = lGc; _Gd = lGd; _Ge = lGe; _Gf = lGf; _Gg = lGg; _Gh = lGh; 139 | 140 | data Gadt2 a b where 141 | C7, C8 :: { gi :: b, gj :: a } -> Gadt2 a b 142 | 143 | mkLabel ''Gadt2 144 | 145 | _Gi :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt2 a b -> Gadt2 a c) (b -> c) 146 | _Gj :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt2 a b -> Gadt2 c b) (a -> c) 147 | 148 | _Gi = lGi; _Gj = lGj; 149 | 150 | ------------------------------------------------------------------------------- 151 | 152 | -- These instance are needed for the `Failing.Lens String` instance, 153 | -- since that needs a `MonadZero` constraint on `Kleisli (Either String)`, 154 | -- which in turn needs a `MonadPlus (Either String)` constraint. 155 | -- These instances used to exist in transformers but were removed in 156 | -- 0.5.0.0 accidentally, and added in 0.5.2.0. We can probably remove 157 | -- this ifdef after GHC 8 rc3 is released, which will include 158 | -- transformers-0.5.2.0. 159 | 160 | #if MIN_VERSION_transformers(0,5,0) && !MIN_VERSION_transformers(0,5,2) && MIN_VERSION_base(4,9,0) && !MIN_VERSION_mtl(2,3,0) 161 | instance (Error e) => Alternative (Either e) where 162 | empty = Left noMsg 163 | Left _ <|> n = n 164 | m <|> _ = m 165 | 166 | instance Error e => MonadPlus (Either e) where 167 | mzero = Left noMsg 168 | Left _ `mplus` n = n 169 | m `mplus` _ = m 170 | #endif 171 | #if MIN_VERSION_mtl(2,3,0) 172 | instance Alternative (Either String) where 173 | empty = Left empty 174 | Left _ <|> n = n 175 | m <|> _ = m 176 | instance MonadPlus (Either String) where 177 | mzero = Left mzero 178 | Left _ `mplus` n = n 179 | m `mplus` _ = m 180 | #endif 181 | ------------------------------------------------------------------------------- 182 | 183 | embed_fB :: Record :~> Newtype Bool 184 | embed_fB = Partial.embed fB 185 | 186 | manual_fA :: Record :-> Integer 187 | manual_fA = Total.lens _fA (\m f -> f { _fA = m (_fA f) }) 188 | 189 | manual_fA_m :: Mono.Lens (->) Record Integer 190 | manual_fA_m = lens _fA (\m f -> f { _fA = m (_fA f) }) 191 | 192 | manual_mA :: Multi :~> Record 193 | manual_mA = Partial.lens 194 | (\p -> case p of First {} -> Just (_mA p); _ -> Nothing) 195 | (\m p -> case p of First {} -> (\v -> p { _mA = v }) `fmap` m (_mA p); _ -> Nothing) 196 | 197 | mA_f :: Failing.Lens String (Multi -> Multi) (Record -> Record) 198 | mA_f = mA 199 | 200 | manual_mA_f :: Failing.Lens String (Multi -> Multi) (Record -> Record) 201 | manual_mA_f = Failing.lens 202 | (\p -> case p of First {} -> Right (_mA p); _ -> Left "mA") 203 | (\m p -> case p of First {} -> (\v -> p { _mA = v }) `fmap` m (_mA p); _ -> Left "mA") 204 | 205 | embed_fD :: Failing.Lens Integer (Record -> Record) (Bool -> Bool) 206 | embed_fD = Failing.embed fD 207 | 208 | manual_dir :: Poly.Lens (->) (Direction i a b c d -> Direction e a b c d) (i -> e) 209 | manual_dir = Poly.lens _dir (\(m, f) -> f {_dir = m (_dir f) }) 210 | 211 | north_f :: Poly.Lens (Failing String) (Direction i a b c d -> Direction i e b c d) (a -> e) 212 | north_f = north 213 | 214 | fAmA :: Multi :~> Integer 215 | fAmA = fA . mA 216 | 217 | recordView :: Record :-> View 218 | recordView = Poly.point $ 219 | View <$> vA >- fB 220 | <*> vB >- fD 221 | <*> vC >- fC 222 | 223 | newtypeId :: Newtype Bool :-> Newtype Bool 224 | newtypeId = Poly.point (id <$> id >- id) 225 | 226 | ------------------------------------------------------------------------------- 227 | 228 | fclabels [d| 229 | 230 | data View2 a 231 | = Con1 { field1 :: Bool 232 | , field2 :: (a, a) 233 | } 234 | | Con2 { field1 :: Bool 235 | , field3 :: [a] 236 | } 237 | 238 | |] 239 | 240 | deriving instance Eq a => Eq (View2 a) 241 | deriving instance Show a => Show (View2 a) 242 | 243 | view :: View2 a :~> Either (Bool, (a, a)) (Bool, [a]) 244 | view = point $ 245 | Left <$> L.left >- con1 246 | <|> Right <$> L.right >- con2 247 | where con1 = point $ 248 | (,) <$> L.fst >- field1 249 | <*> L.snd >- field2 250 | con2 = point $ 251 | (,) <$> L.fst >- field1 252 | <*> L.snd >- field3 253 | 254 | ------------------------------------------------------------------------------- 255 | -- Test data type with large number (> 26) of fields. 256 | 257 | fclabels [d| 258 | 259 | data C = C { c_a :: (), c_b :: (), c_c :: (), c_d :: (), c_e :: (), c_f :: () 260 | , c_g :: (), c_h :: (), c_i :: (), c_j :: (), c_k :: (), c_l :: () 261 | , c_m :: (), c_n :: (), c_o :: (), c_p :: (), c_q :: (), c_r :: () 262 | , c_s :: (), c_t :: (), c_u :: (), c_v :: (), c_w :: (), c_x :: () 263 | , c_y :: (), c_z :: (), c_a0 :: (), c_b0 :: (), c_c0 :: (), c_d0 :: () 264 | } 265 | 266 | |] 267 | 268 | ------------------------------------------------------------------------------- 269 | 270 | newtype0, newtype1, newtype2 :: Newtype Bool 271 | newtype0 = Newtype [] 272 | newtype1 = Newtype [True] 273 | newtype2 = Newtype [False] 274 | 275 | record0, record1, record2, record3, record4, record5, record10, record11 :: Record 276 | record0 = Record 0 Nothing newtype0 (Left 1) 277 | record1 = Record 1 Nothing newtype0 (Left 1) 278 | record2 = Record 0 (Just newtype1) newtype0 (Left 1) 279 | record3 = Record 0 (Just newtype0) newtype0 (Left 1) 280 | record4 = Record 0 Nothing newtype0 (Right True) 281 | record5 = Record 0 Nothing newtype0 (Right False) 282 | record10 = Record 10 Nothing newtype0 (Left 1) 283 | record11 = Record 11 Nothing newtype0 (Left 1) 284 | 285 | first0, first1, first2 :: Multi 286 | first0 = First record0 0.0 (Right 1.0) 287 | first1 = First record0 1.0 (Right 1.0) 288 | first2 = First record1 0.0 (Right 1.0) 289 | 290 | second0, second1 :: Multi 291 | second0 = Second 0.0 292 | second1 = Second 1.0 293 | 294 | north0 :: Direction Integer () () () () 295 | north0 = North 0 () 296 | 297 | north1 :: Direction Bool () () () () 298 | north1 = North False () 299 | 300 | north2 :: Direction Integer Bool () () () 301 | north2 = North 0 False 302 | 303 | west0 :: Direction Integer () () () () 304 | west0 = West 0 () 305 | 306 | mulDiv :: Iso (->) Integer Double 307 | mulDiv = Iso (\i -> fromInteger i / 10) (\i -> round (i * 10)) 308 | 309 | addSub :: Iso (->) Double Integer 310 | addSub = Iso (\i -> round (i + 10)) (\i -> fromInteger i - 10) 311 | 312 | ------------------------------------------------------------------------------- 313 | 314 | main :: IO () 315 | main = 316 | do _ <- runTestTT allTests 317 | return () 318 | 319 | allTests :: Test 320 | allTests = TestList 321 | [ mono 322 | , totalMono 323 | , partialMono 324 | , failingMono 325 | , totalPoly 326 | , partialPoly 327 | , failingPoly 328 | , composition 329 | , applicativeTotal 330 | , applicativePartial 331 | , bijections 332 | , monadic 333 | , base 334 | ] 335 | 336 | mono :: Test 337 | mono = TestList 338 | [ eq "get manual_fA_m" (get manual_fA_m record0) 0 339 | , eq "set manual_fA_m" (set manual_fA_m 1 record0) record1 340 | , eq "mod manual_fA_m" (modify manual_fA_m (+ 1) record0) record1 341 | ] where eq :: (Eq a, Show a) => String -> a -> a -> Test 342 | eq x = equality ("total mono " ++ x) 343 | 344 | totalMono :: Test 345 | totalMono = TestList 346 | [ eq "get fA" (Total.get fA record0) 0 347 | , eq "set fA" (Total.set fA 1 record0) record1 348 | , eq "mod fA" (Total.modify fA (+ 1) record0) record1 349 | , eq "get manual_fA" (Total.get manual_fA record0) 0 350 | , eq "set manual_fA" (Total.set manual_fA 1 record0) record1 351 | , eq "mod manual_fA" (Total.modify manual_fA (+ 1) record0) record1 352 | , eq "get mB" (Total.get mB first0) 0 353 | , eq "set mB" (Total.set mB 1 first0) first1 354 | , eq "mod mB" (Total.modify mB (+ 1) first0) first1 355 | ] where eq :: (Eq a, Show a) => String -> a -> a -> Test 356 | eq x = equality ("total mono " ++ x) 357 | 358 | partialMono :: Test 359 | partialMono = TestList 360 | [ eq0 "get mA" (Partial.get mA first0) (Just record0) 361 | , eq0 "set mA" (Partial.set mA record1 first0) (Just first2) 362 | , eq0 "mod mA" (Partial.modify mA (Total.modify fA (+ 1)) first0) (Just first2) 363 | , eq0 "get manual_mA" (Partial.get manual_mA first0) (Just record0) 364 | , eq0 "set manual_mA" (Partial.set manual_mA record1 first0) (Just first2) 365 | , eq0 "mod manual_mA" (Partial.modify manual_mA (Total.modify fA (+ 1)) first0) (Just first2) 366 | , eq1 "get mA" (Partial.get mA second0) Nothing 367 | , eq1 "set mA" (Partial.set mA record1 second0) Nothing 368 | , eq1 "mod mA" (Partial.modify mA (Total.modify fA (+ 1)) second0) Nothing 369 | , eq1 "get manual_mA" (Partial.get manual_mA second0) Nothing 370 | , eq1 "set manual_mA" (Partial.set manual_mA record1 second0) Nothing 371 | , eq1 "mod manual_mA" (Partial.modify manual_mA (Total.modify fA (+ 1)) second0) Nothing 372 | , eq2 "set mA" (Partial.set' mA record1 first0) first2 373 | , eq2 "mod mA" (Partial.modify' mA (Total.modify fA (+ 1)) first0) first2 374 | , eq2 "set manual_mA" (Partial.set' manual_mA record1 first0) first2 375 | , eq2 "mod manual_mA" (Partial.modify' manual_mA (Total.modify fA (+ 1)) first0) first2 376 | , eq2 "set mA" (Partial.set' mA record1 second0) second0 377 | , eq2 "mod mA" (Partial.modify' mA (Total.modify fA (+ 1)) second0) second0 378 | , eq2 "set manual_mA" (Partial.set' manual_mA record1 second0) second0 379 | , eq2 "mod manual_mA" (Partial.modify' manual_mA (Total.modify fA (+ 1)) second0) second0 380 | , eq3 "get embed_fB" (Partial.get embed_fB record2) (Just newtype1) 381 | , eq3 "set embed_fB" (Partial.set embed_fB newtype0 record2) (Just record3) 382 | , eq3 "mod embed_fB" (Partial.modify embed_fB (const newtype0) record2) (Just record3) 383 | , eq4 "get embed_fB" (Partial.get embed_fB record0) Nothing 384 | , eq4 "set embed_fB" (Partial.set embed_fB newtype0 record0) Nothing 385 | , eq4 "mod embed_fB" (Partial.modify embed_fB (const newtype0) record0) Nothing 386 | ] where eq0, eq1, eq2, eq3, eq4 :: (Eq a, Show a) => String -> a -> a -> Test 387 | eq0 x = equality ("partial mono " ++ x) 388 | eq1 x = equality ("partial mono fail " ++ x) 389 | eq2 x = equality ("partial mono prime " ++ x) 390 | eq3 x = equality ("partial mono embed " ++ x) 391 | eq4 x = equality ("partial mono embed fail" ++ x) 392 | 393 | failingMono :: Test 394 | failingMono = TestList 395 | [ eq0 "get mA_f" (Failing.get mA_f first0) (Right record0) 396 | , eq0 "set mA_f" (Failing.set mA_f record1 first0) (Right first2) 397 | , eq0 "mod mA_f" (Failing.modify mA_f (Total.modify fA (+ 1)) first0) (Right first2) 398 | , eq0 "get manual_mA_f" (Failing.get manual_mA_f first0) (Right record0) 399 | , eq0 "set manual_mA_f" (Failing.set manual_mA_f record1 first0) (Right first2) 400 | , eq0 "mod manual_mA_f" (Failing.modify manual_mA_f (Total.modify fA (+ 1)) first0) (Right first2) 401 | , eq1 "get mA_f fail" (Failing.get mA_f second0) (Left "") 402 | , eq1 "set mA_f fail" (Failing.set mA_f record1 second0) (Left "") 403 | , eq1 "mod mA_f fail" (Failing.modify mA_f (Total.modify fA (+ 1)) second0) (Left "") 404 | , eq1 "get manual_mA_f" (Failing.get manual_mA_f second0) (Left "mA") 405 | , eq1 "set manual_mA_f" (Failing.set manual_mA_f record1 second0) (Left "mA") 406 | , eq1 "mod manual_mA_f" (Failing.modify manual_mA_f (Total.modify fA (+ 1)) second0) (Left "mA") 407 | , eq2 "set mA_f" (Failing.set' mA_f record1 first0) first2 408 | , eq2 "mod mA_f" (Failing.modify' mA_f (Total.modify fA (+ 1)) first0) first2 409 | , eq2 "set manual_mA_f" (Failing.set' manual_mA_f record1 first0) first2 410 | , eq2 "mod manual_mA_f" (Failing.modify' manual_mA_f (Total.modify fA (+ 1)) first0) first2 411 | , eq2 "set mA_f" (Failing.set' mA_f record1 second0) second0 412 | , eq2 "mod mA_f" (Failing.modify' mA_f (Total.modify fA (+ 1)) second0) second0 413 | , eq2 "set manual_mA_f" (Failing.set' manual_mA_f record1 second0) second0 414 | , eq2 "mod manual_mA_f" (Failing.modify' manual_mA_f (Total.modify fA (+ 1)) second0) second0 415 | , eq3 "get embed_fD" (Failing.get embed_fD record4) (Right True) 416 | , eq3 "set embed_fD" (Failing.set embed_fD False record4) (Right record5) 417 | , eq3 "mod embed_fD" (Failing.modify embed_fD not record4) (Right record5) 418 | , eq4 "get embed_fD" (Failing.get embed_fD record0) (Left 1) 419 | , eq4 "set embed_fD" (Failing.set embed_fD False record0) (Left 1) 420 | , eq4 "mod embed_fD" (Failing.modify embed_fD not record0) (Left 1) 421 | ] where eq0, eq1, eq2, eq3, eq4 :: (Eq a, Show a) => String -> a -> a -> Test 422 | eq0 x = equality ("failing mono " ++ x) 423 | eq1 x = equality ("failing mono fail " ++ x) 424 | eq2 x = equality ("failing mono prime " ++ x) 425 | eq3 x = equality ("failing mono embed " ++ x) 426 | eq4 x = equality ("failing mono embed fail " ++ x) 427 | 428 | totalPoly :: Test 429 | totalPoly = TestList 430 | [ eq "get dir" (Total.get dir north0) (0 :: Integer) 431 | , eq "set dir" (Total.set dir False north0) north1 432 | , eq "mod dir" (Total.modify dir (> 1) north0) north1 433 | , eq "get manual_dir" (Total.get manual_dir north0) 0 434 | , eq "set manual_dir" (Total.set manual_dir False north0) north1 435 | , eq "mod manual_dir" (Total.modify manual_dir (> 1) north0) north1 436 | ] where eq :: (Eq a, Show a) => String -> a -> a -> Test 437 | eq x = equality ("total mono " ++ x) 438 | 439 | partialPoly :: Test 440 | partialPoly = TestList 441 | [ eq0 "get north" (Partial.get north north0) (Just ()) 442 | , eq0 "set north" (Partial.set north False north0) (Just north2) 443 | , eq0 "mod north" (Partial.modify north (> ()) north0) (Just north2) 444 | , eq1 "get north" (Partial.get north west0) Nothing 445 | , eq1 "set north" (Partial.set north False west0) Nothing 446 | , eq1 "mod north" (Partial.modify north (> ()) west0) Nothing 447 | ] where eq0, eq1 :: (Eq a, Show a) => String -> a -> a -> Test 448 | eq0 x = equality ("partial poly " ++ x) 449 | eq1 x = equality ("partial poly fail " ++ x) 450 | 451 | failingPoly :: Test 452 | failingPoly = TestList 453 | [ eq0 "get north" (Failing.get north_f north0) (Right ()) 454 | , eq0 "set north" (Failing.set north_f False north0) (Right north2) 455 | , eq0 "mod north" (Failing.modify north_f (> ()) north0) (Right north2) 456 | , eq1 "get north" (Failing.get north_f west0) (Left "north") 457 | , eq1 "set north" (Failing.set north_f False west0) (Left "north") 458 | , eq1 "mod north" (Failing.modify north_f (> ()) west0) (Left "north") 459 | ] where eq0, eq1 :: (Eq a, Show a) => String -> a -> a -> Test 460 | eq0 x = equality ("failing poly " ++ x) 461 | eq1 x = equality ("failing poly fail " ++ x) 462 | 463 | composition :: Test 464 | composition = TestList 465 | [ eq0 "get id" (Partial.get id first0) (Just first0) 466 | , eq0 "set id" (Partial.set id first2 first0) (Just first2) 467 | , eq0 "mod id" (Partial.modify id (const first2) first0) (Just first2) 468 | , eq0 "get fAmA" (Partial.get fAmA first0) (Just 0) 469 | , eq0 "set fAmA" (Partial.set fAmA 1 first0) (Just first2) 470 | , eq0 "mod fAmA" (Partial.modify fAmA (+ 1) first0) (Just first2) 471 | , eq0 "get id fAmA" (Partial.get (id . fAmA) first0) (Just 0) 472 | , eq0 "set id fAmA" (Partial.set (id . fAmA) 1 first0) (Just first2) 473 | , eq0 "mod id fAmA" (Partial.modify (id . fAmA) (+ 1) first0) (Just first2) 474 | , eq0 "get fAmA id" (Partial.get (fAmA . id) first0) (Just 0) 475 | , eq0 "set fAmA id" (Partial.set (fAmA . id) 1 first0) (Just first2) 476 | , eq0 "mod fAmA id" (Partial.modify (fAmA . id) (+ 1) first0) (Just first2) 477 | ] where eq0 :: (Eq a, Show a) => String -> a -> a -> Test 478 | eq0 x = equality ("composition partial mono" ++ x) 479 | 480 | applicativeTotal :: Test 481 | applicativeTotal = TestList 482 | [ eq "get vA" (Total.get (vA . recordView) record0) Nothing 483 | , eq "get vB" (Total.get (vB . recordView) record0) (Left 1) 484 | , eq "get vC" (Total.get (vC . recordView) record0) newtype0 485 | , eq "set vA" (Total.set (vA . recordView) (Just newtype0) record2) record3 486 | , eq "modify vA" (Total.modify (vA . recordView) (fmap (const newtype0)) record2) record3 487 | 488 | , eq "get newtypeId" (Total.get newtypeId newtype0) newtype0 489 | , eq "set newtypeId" (Total.set newtypeId newtype1 newtype0) newtype1 490 | , eq "mod newtypeId" (Total.modify newtypeId (const newtype2) newtype0) newtype2 491 | ] where eq :: (Eq a, Show a) => String -> a -> a -> Test 492 | eq x = equality ("applicative total mono" ++ x) 493 | 494 | myCon1 :: View2 Char 495 | myCon1 = Con1 False ('a', 'z') 496 | 497 | myCon2 :: View2 Char 498 | myCon2 = Con2 True "abc" 499 | 500 | applicativePartial :: Test 501 | applicativePartial = TestList 502 | [ eq "get" (Partial.get (L.snd . L.left . view) myCon1) (Just ('a', 'z')) 503 | , eq "get" (Partial.get (L.snd . L.left . view) myCon2) Nothing 504 | , eq "get" (Partial.get (L.snd . L.right . view) myCon1) Nothing 505 | , eq "get" (Partial.get (L.snd . L.right . view) myCon2) (Just "abc") 506 | , eq "mod" (Partial.modify (L.fst . L.left . view) not myCon1) (Just (Con1 True ('a', 'z'))) 507 | , eq "mod" (Partial.modify (L.fst . L.left . view) not myCon2) Nothing 508 | , eq "mod" (Partial.modify (L.fst . L.right . view) not myCon1) Nothing 509 | , eq "mod" (Partial.modify (L.fst . L.right . view) not myCon2) (Just (Con2 False "abc")) 510 | , eq "mod" (Partial.modify (L.snd . L.left . view) swap myCon1) (Just (Con1 False ('z', 'a'))) 511 | , eq "mod" (Partial.modify (L.snd . L.left . view) swap myCon2) Nothing 512 | , eq "mod" (Partial.modify (L.snd . L.right . view) reverse myCon1) Nothing 513 | , eq "mod" (Partial.modify (L.snd . L.right . view) reverse myCon2) (Just (Con2 True "cba")) 514 | ] where eq :: (Eq a, Show a) => String -> a -> a -> Test 515 | eq x = equality ("applicative partial mono" ++ x) 516 | 517 | bijections :: Test 518 | bijections = TestList 519 | [ eq "get mulDiv" (get (iso mulDiv . fA) record0) 0 520 | , eq "set mulDiv" (set (iso mulDiv . fA) 1 record0) record10 521 | , eq "mod mulDiv" (modify (iso mulDiv . fA) (+ 1) record0) record10 522 | , eq "get addSub" (get (iso (inv addSub) . fA) record0) (-10) 523 | , eq "set addSub" (set (iso (inv addSub) . fA) 1 record0) record11 524 | , eq "mod addSub" (modify (iso (inv addSub) . fA) (+ 1) record0) record1 525 | 526 | , eq "get id mulDiv" (get (iso (id . mulDiv) . fA) record0) 0 527 | , eq "set id mulDiv" (set (iso (id . mulDiv) . fA) 1 record0) record10 528 | , eq "mod id mulDiv" (modify (iso (id . mulDiv) . fA) (+ 1) record0) record10 529 | , eq "get id mulDiv" (get (iso (mulDiv . id) . fA) record0) 0 530 | , eq "set id mulDiv" (set (iso (mulDiv . id) . fA) 1 record0) record10 531 | , eq "mod id mulDiv" (modify (iso (mulDiv . id) . fA) (+ 1) record0) record10 532 | ] where eq :: (Eq a, Show a) => String -> a -> a -> Test 533 | eq x = equality ("isomorphisms mono " ++ x) 534 | 535 | monadic :: Test 536 | monadic = TestList 537 | [ eq "asks id total" (runReader (Monadic.asks id) record0) record0 538 | , eq "asks fC total" (runReader (Monadic.asks fC) record0) newtype0 539 | , eq "gets id total" (evalState (Monadic.gets id) record0) record0 540 | , eq "gets fC total" (evalState (Monadic.gets fC) record0) newtype0 541 | 542 | , eq "put fA total" (execState (fA Monadic.=: 1) record0) record1 543 | , eq "modify fA total" (execState (fA Monadic.=. (+ 1)) record0) record1 544 | 545 | , eq "local fA total" (runReader (Monadic.local fA (+1) $ Monadic.asks id) record0) record1 546 | , eq "modifyAndGet fA total" (runState (Monadic.modifyAndGet fA (\a -> (a+10, a+1))) record0) (10, record1) 547 | ] where eq :: (Eq a, Show a) => String -> a -> a -> Test 548 | eq x = equality ("total monadic " ++ x) 549 | 550 | base :: Test 551 | base = TestList 552 | [ eq "get head" (Partial.get L.head [1, 2, 3]) (Just (1::Int)) 553 | , eq "get head" (Partial.get L.head ([] :: [Int])) Nothing 554 | , eq "get tail" (Partial.get L.tail [1, 2, 3]) (Just [2, 3 ::Int]) 555 | , eq "get tail" (Partial.get L.tail ([] :: [Int])) Nothing 556 | , eq "get left" (Partial.get L.left (Left 'a')) (Just 'a') 557 | , eq "get left" (Partial.get L.left (Right 'a' :: Either () Char)) Nothing 558 | , eq "get right" (Partial.get L.right (Right 'a')) (Just 'a') 559 | , eq "get right" (Partial.get L.right (Left 'a' :: Either Char ())) Nothing 560 | , eq "get just" (Partial.get L.just (Just 'a')) (Just 'a') 561 | , eq "get just" (Partial.get L.just (Nothing :: Maybe Char)) Nothing 562 | , eq "get fst" (Total.get (L.fst . L.swap) ('a', ())) () 563 | , eq "get snd" (Total.get (L.snd . L.swap) ((), 'b')) () 564 | , eq "get fst3" (Total.get L.fst3 ('a', (), ())) 'a' 565 | , eq "get snd3" (Total.get L.snd3 ((), 'b', ())) 'b' 566 | , eq "get trd3" (Total.get L.trd3 ((), (), 'c')) 'c' 567 | , eq "mod head" (Partial.modify L.head (*2) [1, 2, 3]) (Just [2, 2, 3::Int]) 568 | , eq "mod head" (Partial.modify L.head (*2) ([]::[Int])) Nothing 569 | , eq "mod tail" (Partial.modify L.tail reverse [1, 2, 3]) (Just [1, 3, 2::Int]) 570 | , eq "mod tail" (Partial.modify L.tail reverse ([]::[Int])) Nothing 571 | , eq "mod left" (Partial.modify L.left (=='a') (Left 'a')) (Just (Left True :: Either Bool ())) 572 | , eq "mod left" (Partial.modify L.left (=='a') (Right ())) (Nothing :: Maybe (Either Bool ())) 573 | , eq "mod right" (Partial.modify L.right (=='c') (Right 'b')) (Just (Right False :: Either () Bool)) 574 | , eq "mod right" (Partial.modify L.right (=='c') (Left ())) (Nothing :: Maybe (Either () Bool)) 575 | , eq "mod just" (Partial.modify L.just (=='a') (Just 'a')) (Just (Just True)) 576 | , eq "mod just" (Partial.modify L.just (=='a') Nothing) Nothing 577 | , eq "mod fst" (Total.modify (L.fst . L.swap) (== 'a') ((), 'a')) ((), True) 578 | , eq "mod snd" (Total.modify (L.snd . L.swap) (== 'a') ('a', ())) (True, ()) 579 | , eq "mod fst3" (Total.modify L.fst3 (== 'a') ('a', (), ())) (True, (), ()) 580 | , eq "mod snd3" (Total.modify L.snd3 (== 'a') ((), 'b', ())) ((), False, ()) 581 | , eq "mod trd3" (Total.modify L.trd3 (== 'a') ((), (), 'c')) ((), (), False) 582 | ] where eq :: (Eq a, Show a) => String -> a -> a -> Test 583 | eq x = equality ("base" ++ x) 584 | 585 | equality :: (Eq a, Show a) => String -> a -> a -> Test 586 | equality d a b = TestCase (assertEqual d b a) 587 | -------------------------------------------------------------------------------- /src/Data/Label/Derive.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Template Haskell functions for automatically generating labels for algebraic 3 | datatypes, newtypes and GADTs. There are two basic modes of label generation, 4 | the `mkLabels` family of functions create labels (and optionally type 5 | signatures) in scope as top level funtions, the `getLabel` family of funtions 6 | create labels as expressions that can be named and typed manually. 7 | 8 | In the case of multi-constructor datatypes some fields might not always be 9 | available and the derived labels will be partial. Partial labels are provided 10 | with an additional type context that forces them to be only usable in the 11 | `Partial' or `Failing` context. 12 | -} 13 | 14 | {-# LANGUAGE 15 | DeriveFunctor 16 | , DeriveFoldable 17 | , TemplateHaskell 18 | , TypeOperators 19 | , CPP #-} 20 | 21 | module Data.Label.Derive 22 | ( 23 | 24 | -- * Generate labels in scope. 25 | mkLabel 26 | , mkLabels 27 | , mkLabelsNamed 28 | 29 | -- * Produce labels as expressions. 30 | , getLabel 31 | 32 | -- * First class record labels. 33 | , fclabels 34 | 35 | -- * Low level derivation functions. 36 | , mkLabelsWith 37 | , getLabelWith 38 | , defaultNaming 39 | ) 40 | where 41 | 42 | import Control.Applicative 43 | import Control.Arrow 44 | import Control.Category 45 | import Control.Monad 46 | import Data.Char (toLower, toUpper) 47 | #if MIN_VERSION_base(4,8,0) 48 | import Data.Foldable (toList) 49 | #else 50 | import Data.Foldable (Foldable, toList) 51 | #endif 52 | import Data.Label.Point 53 | import Data.List (groupBy, sortBy, delete, nub) 54 | import Data.Maybe (fromMaybe) 55 | import Data.Ord 56 | 57 | #if MIN_VERSION_template_haskell(2,17,0) 58 | import Language.Haskell.TH hiding (classP) 59 | #elif MIN_VERSION_template_haskell(2,10,0) 60 | import qualified Language.Haskell.TH as TH 61 | import Language.Haskell.TH hiding (classP, TyVarBndr) 62 | #else 63 | import qualified Language.Haskell.TH as TH 64 | import Language.Haskell.TH hiding (TyVarBndr) 65 | #endif 66 | 67 | import Prelude hiding ((.), id) 68 | 69 | import qualified Data.Label.Mono as Mono 70 | import qualified Data.Label.Poly as Poly 71 | 72 | 73 | #if MIN_VERSION_template_haskell(2,17,0) 74 | #else 75 | data Specificity = SpecifiedSpec -- old versions don't have this 76 | type TyVarBndr a = TH.TyVarBndr 77 | #endif 78 | 79 | ------------------------------------------------------------------------------- 80 | -- Publicly exposed functions. 81 | 82 | -- | Derive labels including type signatures for all the record selectors for a 83 | -- collection of datatypes. The types will be polymorphic and can be used in an 84 | -- arbitrary context. 85 | 86 | mkLabels :: [Name] -> Q [Dec] 87 | mkLabels = liftM concat . mapM (mkLabelsWith defaultNaming True False False True) 88 | 89 | -- | Derive labels including type signatures for all the record selectors in a 90 | -- single datatype. The types will be polymorphic and can be used in an 91 | -- arbitrary context. 92 | 93 | mkLabel :: Name -> Q [Dec] 94 | mkLabel = mkLabels . return 95 | 96 | -- | Like `mkLabels`, but uses the specified function to produce custom names 97 | -- for the labels. 98 | -- 99 | -- For instance, @(drop 1 . dropWhile (/='_'))@ creates a label 100 | -- @val@ from a record @Rec { rec_val :: X }@. 101 | 102 | mkLabelsNamed :: (String -> String) -> [Name] -> Q [Dec] 103 | mkLabelsNamed mk = liftM concat . mapM (mkLabelsWith mk True False False True) 104 | 105 | -- | Derive unnamed labels as n-tuples that can be named manually. The types 106 | -- will be polymorphic and can be used in an arbitrary context. 107 | -- 108 | -- Example: 109 | -- 110 | -- > (left, right) = $(getLabel ''Either) 111 | -- 112 | -- The lenses can now also be typed manually: 113 | -- 114 | -- > left :: (Either a b -> Either c b) :~> (a -> c) 115 | -- > right :: (Either a b -> Either a c) :~> (b -> c) 116 | -- 117 | -- Note: Because of the abstract nature of the generated lenses and the top 118 | -- level pattern match, it might be required to use 'NoMonomorphismRestriction' 119 | -- in some cases. 120 | 121 | getLabel :: Name -> Q Exp 122 | getLabel = getLabelWith True False False 123 | 124 | -- | Low level label as expression derivation function. 125 | 126 | getLabelWith 127 | :: Bool -- ^ Generate type signatures or not. 128 | -> Bool -- ^ Generate concrete type or abstract type. When true the 129 | -- signatures will be concrete and can only be used in the 130 | -- appropriate context. Total labels will use (`:->`) and partial 131 | -- labels will use either `Lens Partial` or `Lens Failing` 132 | -- dependent on the following flag: 133 | -> Bool -- ^ Use `ArrowFail` for failure instead of `ArrowZero`. 134 | -> Name -- ^ The type to derive labels for. 135 | -> Q Exp 136 | 137 | getLabelWith sigs concrete failing name = 138 | do dec <- reifyDec name 139 | labels <- generateLabels id concrete failing dec 140 | let bodies = map (\(LabelExpr _ _ _ b) -> b) labels 141 | types = map (\(LabelExpr _ _ t _) -> t) labels 142 | context = head $ map (\(LabelExpr _ c _ _) -> c) labels 143 | vars = head $ map (\(LabelExpr v _ _ _) -> v) labels 144 | case bodies of 145 | [b] -> if sigs then b `sigE` forallT vars context (head types) else b 146 | _ -> if sigs 147 | then tupE bodies `sigE` 148 | forallT vars context (foldl appT (tupleT (length bodies)) types) 149 | else tupE bodies 150 | 151 | -- | Low level standalone label derivation function. 152 | 153 | mkLabelsWith 154 | :: (String -> String) -- ^ Supply a function to perform custom label naming. 155 | -> Bool -- ^ Generate type signatures or not. 156 | -> Bool -- ^ Generate concrete type or abstract type. When 157 | -- true the signatures will be concrete and can only 158 | -- be used in the appropriate context. Total labels 159 | -- will use (`:->`) and partial labels will use 160 | -- either `Lens Partial` or `Lens Failing` dependent 161 | -- on the following flag: 162 | -> Bool -- ^ Use `ArrowFail` for failure instead of `ArrowZero`. 163 | -> Bool -- ^ Generate inline pragma or not. 164 | -> Name -- ^ The type to derive labels for. 165 | -> Q [Dec] 166 | 167 | mkLabelsWith mk sigs concrete failing inl name = 168 | do dec <- reifyDec name 169 | mkLabelsWithForDec mk sigs concrete failing inl dec 170 | 171 | -- | Default way of generating a label name from the Haskell record selector 172 | -- name. If the original selector starts with an underscore, remove it and make 173 | -- the next character lowercase. Otherwise, add 'l', and make the next 174 | -- character uppercase. 175 | 176 | defaultNaming :: String -> String 177 | defaultNaming field = 178 | case field of 179 | '_' : c : rest -> toLower c : rest 180 | f : rest -> 'l' : toUpper f : rest 181 | n -> fclError ("Cannot derive label for record selector with name: " ++ n) 182 | 183 | -- | Derive labels for all the record types in the supplied declaration. The 184 | -- record fields don't need an underscore prefix. Multiple data types / 185 | -- newtypes are allowed at once. 186 | -- 187 | -- The advantage of this approach is that you don't need to explicitly hide the 188 | -- original record accessors from being exported and they won't show up in the 189 | -- derived `Show` instance. 190 | -- 191 | -- Example: 192 | -- 193 | -- > fclabels [d| 194 | -- > data Record = Record 195 | -- > { int :: Int 196 | -- > , bool :: Bool 197 | -- > } deriving Show 198 | -- > |] 199 | -- 200 | -- > ghci> modify int (+2) (Record 1 False) 201 | -- > Record 3 False 202 | 203 | fclabels :: Q [Dec] -> Q [Dec] 204 | fclabels decls = 205 | do ds <- decls 206 | ls <- forM (ds >>= labels) (mkLabelsWithForDec id True False False False) 207 | return (concat ((delabelize <$> ds) : ls)) 208 | where 209 | 210 | labels :: Dec -> [Dec] 211 | labels dec = 212 | case dec of 213 | DataD {} -> [dec] 214 | NewtypeD {} -> [dec] 215 | _ -> [] 216 | 217 | delabelize :: Dec -> Dec 218 | delabelize dec = 219 | case dec of 220 | #if MIN_VERSION_template_haskell(2,11,0) 221 | DataD ctx nm vars mk cs ns -> DataD ctx nm vars mk (con <$> cs) ns 222 | NewtypeD ctx nm vars mk c ns -> NewtypeD ctx nm vars mk (con c) ns 223 | #else 224 | DataD ctx nm vars cs ns -> DataD ctx nm vars (con <$> cs) ns 225 | NewtypeD ctx nm vars c ns -> NewtypeD ctx nm vars (con c) ns 226 | #endif 227 | rest -> rest 228 | where con (RecC n vst) = NormalC n (map (\(_, s, t) -> (s, t)) vst) 229 | #if MIN_VERSION_template_haskell(2,11,0) 230 | con (RecGadtC ns vst ty) = GadtC ns (map (\(_, s, t) -> (s, t)) vst) ty 231 | #endif 232 | con c = c 233 | 234 | ------------------------------------------------------------------------------- 235 | -- Intermediate data types. 236 | 237 | data Label 238 | = LabelDecl 239 | Name -- The label name. 240 | DecQ -- An INLINE pragma for the label. 241 | [TyVarBndr Specificity] -- The type variables requiring forall. 242 | CxtQ -- The context. 243 | TypeQ -- The type. 244 | ExpQ -- The label body. 245 | | LabelExpr 246 | [TyVarBndr Specificity] -- The type variables requiring forall. 247 | CxtQ -- The context. 248 | TypeQ -- The type. 249 | ExpQ -- The label body. 250 | 251 | data Field c = Field 252 | (Maybe Name) -- Name of the field, when there is one. 253 | Bool -- Forced to be mono because of type shared with other fields. 254 | Type -- Type of the field. 255 | c -- Occurs in this/these constructors. 256 | deriving (Eq, Functor, Foldable) 257 | 258 | type Subst = [(Type, Type)] 259 | 260 | data Context = Context 261 | Int -- Field index. 262 | Name -- Constructor name. 263 | Con -- Constructor. 264 | deriving (Eq, Show) 265 | 266 | data Typing = Typing 267 | Bool -- Monomorphic type or polymorphic. 268 | TypeQ -- The lens input type. 269 | TypeQ -- The lens output type. 270 | [TyVarBndr Specificity] -- All used type variables. 271 | 272 | ------------------------------------------------------------------------------- 273 | 274 | mkLabelsWithForDec :: (String -> String) -> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec] 275 | mkLabelsWithForDec mk sigs concrete failing inl dec = 276 | do labels <- generateLabels mk concrete failing dec 277 | decls <- forM labels $ \l -> 278 | case l of 279 | LabelExpr {} -> return [] 280 | LabelDecl n i v c t b -> 281 | do bdy <- pure <$> funD n [clause [] (normalB b) []] 282 | prg <- if inl then pure <$> i else return [] 283 | typ <- if sigs 284 | then pure <$> sigD n (forallT v c t) 285 | else return [] 286 | return (concat [prg, typ, bdy]) 287 | return (concat decls) 288 | 289 | -- Generate the labels for all the record fields in the data type. 290 | 291 | generateLabels :: (String -> String) -> Bool -> Bool -> Dec -> Q [Label] 292 | generateLabels mk concrete failing dec = 293 | 294 | do -- Only process data and newtype declarations, filter out all 295 | -- constructors and the type variables. 296 | let (name, cons, vars) = 297 | case dec of 298 | #if MIN_VERSION_template_haskell(2,11,0) 299 | DataD _ n vs _ cs _ -> (n, cs, vs) 300 | NewtypeD _ n vs _ c _ -> (n, [c], vs) 301 | #else 302 | DataD _ n vs cs _ -> (n, cs, vs) 303 | NewtypeD _ n vs c _ -> (n, [c], vs) 304 | #endif 305 | _ -> fclError "Can only derive labels for datatypes and newtypes." 306 | 307 | -- We are only interested in lenses of record constructors. 308 | fields = groupFields mk vars cons 309 | 310 | forM fields $ generateLabel failing concrete name vars cons 311 | 312 | groupFields :: (String -> String) -> [TyVarBndr a] -> [Con] 313 | -> [Field ([Context], Subst)] 314 | groupFields mk vs 315 | = map (rename mk) 316 | . concatMap (\fs -> let vals = concat (toList <$> fs) 317 | cons = fst <$> vals 318 | subst = concat (snd <$> vals) 319 | in nub (fmap (const (cons, subst)) <$> fs) 320 | ) 321 | . groupBy eq 322 | . sortBy (comparing name) 323 | . concatMap (constructorFields vs) 324 | where name (Field n _ _ _) = n 325 | eq f g = False `fromMaybe` ((==) <$> name f <*> name g) 326 | rename f (Field n a b c) = 327 | Field (mkName . f . nameBase <$> n) a b c 328 | 329 | constructorFields :: [TyVarBndr a] -> Con -> [Field (Context, Subst)] 330 | constructorFields vs con = 331 | 332 | case con of 333 | 334 | NormalC c fs -> one <$> zip [0..] fs 335 | where one (i, f@(_, ty)) = Field Nothing mono ty (Context i c con, []) 336 | where fsTys = map (typeVariables . snd) (delete f fs) 337 | mono = any (\x -> any (elem x) fsTys) (typeVariables ty) 338 | 339 | RecC c fs -> one <$> zip [0..] fs 340 | where one (i, f@(n, _, ty)) = Field (Just n) mono ty (Context i c con, []) 341 | where fsTys = map (typeVariables . trd) (delete f fs) 342 | mono = any (\x -> any (elem x) fsTys) (typeVariables ty) 343 | 344 | InfixC a c b -> one <$> [(0, a), (1, b)] 345 | where one (i, (_, ty)) = Field Nothing mono ty (Context i c con, []) 346 | where fsTys = map (typeVariables . snd) [a, b] 347 | mono = any (\x -> any (elem x) fsTys) (typeVariables ty) 348 | 349 | ForallC x y v -> setEqs <$> constructorFields vs v 350 | #if MIN_VERSION_template_haskell(2,10,0) 351 | where eqs = [ (a, b) | AppT (AppT EqualityT a) b <- y ] 352 | #else 353 | where eqs = [ (a, b) | EqualP a b <- y ] 354 | #endif 355 | setEqs (Field a b c d) = Field a b c (first upd . second (eqs ++) $ d) 356 | upd (Context a b c) = Context a b (ForallC x y c) 357 | #if MIN_VERSION_template_haskell(2,11,0) 358 | GadtC cs fs resTy -> concatMap (\c -> one c <$> zip [0..] fs) cs 359 | where one c (i, f@(_, ty)) = Field Nothing mono ty (Context i c con, mkSubst vs resTy) 360 | where fsTys = map (typeVariables . snd) (delete f fs) 361 | mono = any (\x -> any (elem x) fsTys) (typeVariables ty) 362 | RecGadtC cs fs resTy -> concatMap (\c -> one c <$> zip [0..] fs) cs 363 | where one c (i, f@(n, _, ty)) = Field (Just n) mono ty (Context i c con, mkSubst vs resTy) 364 | where fsTys = map (typeVariables . trd) (delete f fs) 365 | mono = any (\x -> any (elem x) fsTys) (typeVariables ty) 366 | 367 | mkSubst :: [TyVarBndr a] -> Type -> Subst 368 | mkSubst vars t = go (reverse vars) t 369 | where 370 | go [] _ = [] 371 | go (v:vs) (AppT t1 t2) = (typeFromBinder v, t2) : go vs t1 372 | go _ _ = fclError "Non-AppT with type variables in mkSubst. Please report this as a bug for fclabels." 373 | #endif 374 | 375 | prune :: [Context] -> [Con] -> [Con] 376 | prune contexts allCons = 377 | case contexts of 378 | (Context _ _ con) : _ 379 | -> filter (unifiableCon con) allCons 380 | [] -> [] 381 | 382 | unifiableCon :: Con -> Con -> Bool 383 | unifiableCon a b = and (zipWith unifiable (indices a) (indices b)) 384 | where indices con = 385 | case con of 386 | NormalC {} -> [] 387 | RecC {} -> [] 388 | InfixC {} -> [] 389 | #if MIN_VERSION_template_haskell(2,11,0) 390 | ForallC _ _ ty -> indices ty 391 | #elif MIN_VERSION_template_haskell(2,10,0) 392 | ForallC _ x _ -> [ c | AppT (AppT EqualityT _) c <- x ] 393 | #else 394 | ForallC _ x _ -> [ c | EqualP _ c <- x ] 395 | #endif 396 | #if MIN_VERSION_template_haskell(2,11,0) 397 | GadtC _ _ ty -> conIndices ty 398 | RecGadtC _ _ ty -> conIndices ty 399 | where 400 | conIndices (AppT (ConT _) ty) = [ty] 401 | conIndices (AppT rest ty) = conIndices rest ++ [ty] 402 | conIndices _ = fclError "Non-AppT in conIndices. Please report this as a bug for fclabels." 403 | #endif 404 | 405 | unifiable :: Type -> Type -> Bool 406 | unifiable x y = 407 | case (x, y) of 408 | ( VarT _ , _ ) -> True 409 | ( _ , VarT _ ) -> True 410 | ( AppT a b , AppT c d ) -> unifiable a c && unifiable b d 411 | ( SigT t k , SigT s j ) -> unifiable t s && k == j 412 | ( ForallT _ _ t , ForallT _ _ s ) -> unifiable t s 413 | ( a , b ) -> a == b 414 | 415 | generateLabel 416 | :: Bool 417 | -> Bool 418 | -> Name 419 | #if MIN_VERSION_template_haskell(2,21,0) 420 | -> [TyVarBndr BndrVis] 421 | #else 422 | -> [TyVarBndr ()] 423 | #endif 424 | -> [Con] 425 | -> Field ([Context], Subst) 426 | -> Q Label 427 | 428 | generateLabel failing concrete datatype dtVars allCons 429 | field@(Field name forcedMono fieldtype (contexts, subst)) = 430 | 431 | do let total = length contexts == length (prune contexts allCons) 432 | 433 | (Typing mono tyI tyO _) 434 | <- computeTypes forcedMono fieldtype datatype dtVars subst 435 | 436 | let cat = varT (mkName "cat") 437 | failE = if failing 438 | then [| failArrow |] 439 | else [| zeroArrow |] 440 | getT = [| arr $(getter failing total field) |] 441 | putT = [| arr $(setter failing total field) |] 442 | getP = [| $(failE) ||| id <<< $getT |] 443 | putP = [| $(failE) ||| id <<< $putT |] 444 | failP = if failing 445 | then classP ''ArrowFail [ [t| String |], cat] 446 | else classP ''ArrowZero [cat] 447 | ctx = if total 448 | then cxt [ classP ''ArrowApply [cat] ] 449 | else cxt [ classP ''ArrowChoice [cat] 450 | , classP ''ArrowApply [cat] 451 | , failP 452 | ] 453 | body = if total 454 | then [| Poly.point $ Point $getT (modifier $getT $putT) |] 455 | else [| Poly.point $ Point $getP (modifier $getP $putP) |] 456 | cont = if concrete 457 | then cxt [] 458 | else ctx 459 | partial = if failing 460 | then [t| Failing String |] 461 | else [t| Partial |] 462 | concTy = if total 463 | then if mono 464 | then [t| Mono.Lens Total $tyI $tyO |] 465 | else [t| Poly.Lens Total $tyI $tyO |] 466 | else if mono 467 | then [t| Mono.Lens $partial $tyI $tyO |] 468 | else [t| Poly.Lens $partial $tyI $tyO |] 469 | ty = if concrete 470 | then concTy 471 | else if mono 472 | then [t| Mono.Lens $cat $tyI $tyO |] 473 | else [t| Poly.Lens $cat $tyI $tyO |] 474 | 475 | tvs <- nub . binderFromType <$> ty 476 | return $ 477 | case name of 478 | Nothing -> LabelExpr tvs cont ty body 479 | Just n -> 480 | 481 | #if MIN_VERSION_template_haskell(2,8,0) 482 | -- Generate an inline declaration for the label. 483 | -- Type of InlineSpec removed in TH-2.8.0 (GHC 7.6) 484 | let inline = InlineP n Inline FunLike (FromPhase 0) 485 | #else 486 | let inline = InlineP n (InlineSpec True True (Just (True, 0))) 487 | #endif 488 | in LabelDecl n (return (PragmaD inline)) tvs cont ty body 489 | 490 | -- Build a total polymorphic modification function from a getter and setter. 491 | 492 | modifier :: ArrowApply cat => cat f o -> cat (i, f) g -> cat (cat o i, f) g 493 | modifier g m = m . first app . arr (\(n, (f, o)) -> ((n, o), f)) . second (id &&& g) 494 | {-# INLINE modifier #-} 495 | 496 | ------------------------------------------------------------------------------- 497 | 498 | getter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp 499 | getter failing total (Field mn _ _ (cons, _)) = 500 | do let pt = mkName "f" 501 | nm = maybe (tupE []) (litE . StringL . nameBase) (guard failing >> mn) 502 | wild = if total then [] else [match wildP (normalB [| Left $(nm) |]) []] 503 | rght = if total then id else appE [| Right |] 504 | mkCase (Context i _ c) = map (\(pat, var) -> match pat (normalB (rght var)) []) (case1 i c) 505 | lamE [varP pt] 506 | (caseE (varE pt) (concatMap mkCase cons ++ wild)) 507 | where 508 | case1 :: Int -> Con -> [(Q Pat, Q Exp)] 509 | case1 i con = 510 | case con of 511 | NormalC c fs -> [one fs c] 512 | RecC c fs -> [one fs c] 513 | InfixC _ c _ -> [(infixP (pats !! 0) c (pats !! 1), var)] 514 | ForallC _ _ c -> case1 i c 515 | #if MIN_VERSION_template_haskell(2,11,0) 516 | GadtC cs fs _ -> map (one fs) cs 517 | RecGadtC cs fs _ -> map (one fs) cs 518 | #endif 519 | where fresh = mkName <$> delete "f" freshNames 520 | pats1 = varP <$> fresh 521 | pats = replicate i wildP ++ [pats1 !! i] ++ repeat wildP 522 | var = varE (fresh !! i) 523 | one fs c = let s = take (length fs) in (conP c (s pats), var) 524 | 525 | setter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp 526 | setter failing total (Field mn _ _ (cons, _)) = 527 | do let pt = mkName "f" 528 | md = mkName "v" 529 | nm = maybe (tupE []) (litE . StringL . nameBase) (guard failing >> mn) 530 | wild = if total then [] else [match wildP (normalB [| Left $(nm) |]) []] 531 | rght = if total then id else appE [| Right |] 532 | mkCase (Context i _ c) = map (\(pat, var) -> match pat (normalB (rght var)) []) (case1 i c) 533 | lamE [tupP [varP md, varP pt]] 534 | (caseE (varE pt) (concatMap mkCase cons ++ wild)) 535 | where 536 | case1 i con = 537 | case con of 538 | NormalC c fs -> [one fs c] 539 | RecC c fs -> [one fs c] 540 | InfixC _ c _ -> [( infixP (pats !! 0) c (pats !! 1) 541 | , infixE (Just (vars !! 0)) (conE c) (Just (vars !! 1)) 542 | ) 543 | ] 544 | ForallC _ _ c -> case1 i c 545 | #if MIN_VERSION_template_haskell(2,11,0) 546 | GadtC cs fs _ -> map (one fs) cs 547 | RecGadtC cs fs _ -> map (one fs) cs 548 | #endif 549 | where fresh = mkName <$> delete "f" (delete "v" freshNames) 550 | pats1 = varP <$> fresh 551 | pats = take i pats1 ++ [wildP] ++ drop (i + 1) pats1 552 | vars1 = varE <$> fresh 553 | v = varE (mkName "v") 554 | vars = take i vars1 ++ [v] ++ drop (i + 1) vars1 555 | apps f as = foldl appE f as 556 | one fs c = let s = take (length fs) in (conP c (s pats), apps (conE c) (s vars)) 557 | 558 | freshNames :: [String] 559 | freshNames = map pure ['a'..'z'] ++ map (('a':) . show) [0 :: Integer ..] 560 | 561 | ------------------------------------------------------------------------------- 562 | 563 | #if MIN_VERSION_template_haskell(2,21,0) 564 | computeTypes :: Bool -> Type -> Name -> [TyVarBndr BndrVis] -> Subst -> Q Typing 565 | #else 566 | computeTypes :: Bool -> Type -> Name -> [TyVarBndr ()] -> Subst -> Q Typing 567 | #endif 568 | computeTypes forcedMono fieldtype datatype dtVars_ subst = 569 | 570 | do let fieldVars = typeVariables fieldtype 571 | tyO = return fieldtype 572 | dtTypes = substitute subst . typeFromBinder <$> dtVars_ 573 | dtBinders = concatMap binderFromType dtTypes 574 | varNames = nameFromBinder <$> dtBinders 575 | usedVars = filter (`elem` fieldVars) varNames 576 | tyI = return $ foldr (flip AppT) (ConT datatype) (reverse dtTypes) 577 | pretties = mapTyVarBndr pretty <$> dtBinders 578 | mono = forcedMono || isMonomorphic fieldtype dtBinders 579 | 580 | if mono 581 | then return $ Typing 582 | mono 583 | (prettyType <$> tyI) 584 | (prettyType <$> tyO) 585 | (nub pretties) 586 | else 587 | do let names = return <$> ['a'..'z'] 588 | used = show . pretty <$> varNames 589 | free = filter (not . (`elem` used)) names 590 | subs <- forM (zip usedVars free) (\(a, b) -> (,) a <$> newName b) 591 | let rename = mapTypeVariables (\a -> a `fromMaybe` lookup a subs) 592 | 593 | return $ Typing 594 | mono 595 | (prettyType <$> [t| $tyI -> $(rename <$> tyI) |]) 596 | (prettyType <$> [t| $tyO -> $(rename <$> tyO) |]) 597 | (nub (pretties ++ map (mapTyVarBndr pretty) 598 | #if MIN_VERSION_template_haskell(2,17,0) 599 | (flip PlainTV SpecifiedSpec . snd <$> subs))) 600 | #else 601 | (PlainTV . snd <$> subs))) 602 | #endif 603 | 604 | isMonomorphic :: Type -> [TyVarBndr Specificity] -> Bool 605 | isMonomorphic field vars = 606 | let fieldVars = typeVariables field 607 | varNames = nameFromBinder <$> vars 608 | usedVars = filter (`elem` fieldVars) varNames 609 | in null usedVars 610 | 611 | ------------------------------------------------------------------------------- 612 | -- Generic helper functions dealing with Template Haskell 613 | 614 | typeVariables :: Type -> [Name] 615 | typeVariables = map nameFromBinder . binderFromType 616 | 617 | typeFromBinder :: TyVarBndr a -> Type 618 | #if MIN_VERSION_template_haskell(2,17,0) 619 | typeFromBinder (PlainTV tv _) = VarT tv 620 | #else 621 | typeFromBinder (PlainTV tv ) = VarT tv 622 | #endif 623 | 624 | #if MIN_VERSION_template_haskell(2,17,0) 625 | typeFromBinder (KindedTV tv _ StarT) = VarT tv 626 | typeFromBinder (KindedTV tv _ kind) = SigT (VarT tv) kind 627 | #elif MIN_VERSION_template_haskell(2,8,0) 628 | typeFromBinder (KindedTV tv StarT) = VarT tv 629 | typeFromBinder (KindedTV tv kind) = SigT (VarT tv) kind 630 | #else 631 | typeFromBinder (KindedTV tv StarK) = VarT tv 632 | typeFromBinder (KindedTV tv kind) = SigT (VarT tv) kind 633 | #endif 634 | 635 | binderFromType :: Type -> [TyVarBndr Specificity] 636 | binderFromType = go 637 | where 638 | go ty = 639 | case ty of 640 | ForallT ts _ _ -> ts 641 | AppT a b -> go a ++ go b 642 | SigT t _ -> go t 643 | #if MIN_VERSION_template_haskell(2,17,0) 644 | VarT n -> [PlainTV n SpecifiedSpec] 645 | #else 646 | VarT n -> [PlainTV n] 647 | #endif 648 | _ -> [] 649 | 650 | mapTypeVariables :: (Name -> Name) -> Type -> Type 651 | mapTypeVariables f = go 652 | where 653 | go ty = 654 | case ty of 655 | ForallT ts a b -> ForallT (mapTyVarBndr f <$> ts) 656 | (mapPred f <$> a) (go b) 657 | AppT a b -> AppT (go a) (go b) 658 | SigT t a -> SigT (go t) a 659 | VarT n -> VarT (f n) 660 | t -> t 661 | 662 | mapType :: (Type -> Type) -> Type -> Type 663 | mapType f = go 664 | where 665 | go ty = 666 | case ty of 667 | ForallT v c t -> f (ForallT v c (go t)) 668 | AppT a b -> f (AppT (go a) (go b)) 669 | SigT t k -> f (SigT (go t) k) 670 | _ -> f ty 671 | 672 | substitute :: Subst -> Type -> Type 673 | substitute env = mapType sub 674 | where sub v = case lookup v env of 675 | Nothing -> v 676 | Just w -> w 677 | 678 | nameFromBinder :: TyVarBndr Specificity -> Name 679 | #if MIN_VERSION_template_haskell(2,17,0) 680 | nameFromBinder (PlainTV n _) = n 681 | nameFromBinder (KindedTV n _ _) = n 682 | #else 683 | nameFromBinder (PlainTV n ) = n 684 | nameFromBinder (KindedTV n _) = n 685 | #endif 686 | 687 | mapPred :: (Name -> Name) -> Pred -> Pred 688 | #if MIN_VERSION_template_haskell(2,10,0) 689 | mapPred = mapTypeVariables 690 | #else 691 | mapPred f (ClassP n ts) = ClassP (f n) (mapTypeVariables f <$> ts) 692 | mapPred f (EqualP t x ) = EqualP (mapTypeVariables f t) (mapTypeVariables f x) 693 | #endif 694 | 695 | mapTyVarBndr :: (Name -> Name) -> TyVarBndr Specificity 696 | -> TyVarBndr Specificity 697 | #if MIN_VERSION_template_haskell(2,17,0) 698 | mapTyVarBndr f (PlainTV n flag) = PlainTV (f n) flag 699 | mapTyVarBndr f (KindedTV n a flag) = KindedTV (f n) a flag 700 | #else 701 | mapTyVarBndr f (PlainTV n) = PlainTV (f n) 702 | mapTyVarBndr f (KindedTV n a) = KindedTV (f n) a 703 | #endif 704 | 705 | -- Prettify a TH name. 706 | 707 | pretty :: Name -> Name 708 | pretty tv = mkName (takeWhile (/= '_') (show tv)) 709 | 710 | -- Prettify a type. 711 | 712 | prettyType :: Type -> Type 713 | prettyType = mapTypeVariables pretty 714 | 715 | -- Reify a name into a declaration. 716 | 717 | reifyDec :: Name -> Q Dec 718 | reifyDec name = 719 | do info <- reify name 720 | case info of 721 | TyConI dec -> return dec 722 | _ -> fclError "Info must be type declaration type." 723 | 724 | -- Throw a fclabels specific error. 725 | 726 | fclError :: String -> a 727 | fclError err = error ("Data.Label.Derive: " ++ err) 728 | 729 | #if MIN_VERSION_template_haskell(2,10,0) 730 | classP :: Name -> [Q Type] -> Q Pred 731 | classP cla tys 732 | = do tysl <- sequence tys 733 | return (foldl AppT (ConT cla) tysl) 734 | #endif 735 | 736 | trd :: (a, b, c) -> c 737 | trd (_, _, x) = x 738 | --------------------------------------------------------------------------------