generic-lens-2.2.2.0/0000755000000000000000000000000007346545000012417 5ustar0000000000000000generic-lens-2.2.2.0/ChangeLog.md0000644000000000000000000000507107346545000014573 0ustar0000000000000000## generic-lens-2.2.2.0 (2023-04-15) - Support unprefixed constructor prisms on GHC 9.6 (#152) ## generic-lens-2.2.1.0 (2022-01-22) - GHC 9.2 compatibility ## generic-lens-2.2.0.0 (2021-07-13) - GHC 9.0 compatibility ## generic-lens-2.1.0.0 (2021-01-25) - Bump to generic-lens-core-2.1.0.0 ## generic-lens-2.0.0.0 (2020-02-11) - Drop support for GHC < 8.4 - Better inference for `field'` - Param traversal now properly recurses deeply (#88) - Reorganise internals (see generic-lens-core) ### Breaking API changes: - `HasTypesUsing` now takes 4 params - Removed `HasConstraints` traversal ## generic-lens-1.2.0.1 - Give HasAny/AsAny the same VTA behavior on 8.6 and 8.8 (Ryan Scott) ## generic-lens-1.2.0.0 - Add `HasTypesUsing` and `HasTypesCustom` for custom traversals (Lysxia) - Improve type errors when no Generic instance is defined - `types` now supports Text by default ### Breaking API changes - `HasType` now includes a reflexive case so that every type 'contains' itself (Matt Parsons) - `AsSubtype` and `Subtype` now include a reflexive case so that every type is a subtype of itself ## generic-lens-1.1.0.0 - Fix regression in type inference for polymorphic optics - Add `HasField0`, `HasPosition0`, `AsConstructor0`, `HasField_`, `HasPositon_`, and `AsConstructor_` (Lysxia) - `types` now supports Data.Word and Data.Int (Lysxia) - Add `Wrapped` iso for newtypes (Isaac Elliott) - Expose internals through Data.GenericLens.Internal - Add labels for prisms (Daniel Winograd-Cort) ## generic-lens-1.0.0.2 - Fix compile-time performance regression ## generic-lens-1.0.0.1 - Remove dump-core dependency - Relax upper bound on criterion (#42) ## generic-lens-1.0.0.0 - Traversals (types, param, constraints) - Prisms are now optimal too - Monomorphic versions of lenses and prisms also included ### Breaking API changes - `projectSub` now returns `Maybe sub` instead of `Either sup sub` (#21) ## generic-lens-0.5.1.0 - Infer input type from result type (#25) - Allow changing of multiple type parameters (#24) - Allow changing of type parameters that have kinds other than `*` (#23) - Fix error message in subtype lens ## generic-lens-0.5.0.0 - Lenses and prisms are now type-changing. - More informative error messages - More readable type signatures in type errors and when using `:t` - Use `doctest` - Include examples in Haddock ### Breaking API changes - The type parameters of the classes have been changed to accommodate the type-changing update: `class HasField name a s` -> `class HasField name s t a b` etc. Accordingly, `field :: Lens' s a` -> `field :: Lens s t a b` generic-lens-2.2.2.0/LICENSE0000644000000000000000000000276207346545000013433 0ustar0000000000000000Copyright (c) 2020, Csongor Kiss All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Csongor Kiss nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. generic-lens-2.2.2.0/Setup.hs0000644000000000000000000000005607346545000014054 0ustar0000000000000000import Distribution.Simple main = defaultMain generic-lens-2.2.2.0/examples/0000755000000000000000000000000007346545000014235 5ustar0000000000000000generic-lens-2.2.2.0/examples/Examples.hs0000644000000000000000000000676307346545000016363 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} module Examples where import Data.Function ((&)) import Data.Generics.Internal.VL.Lens import Data.Generics.Product import Data.Generics.Sum import GHC.Generics import Data.Generics.Labels import Data.Generics.Internal.VL.Iso import Data.Generics.Internal.VL.Prism import Data.Generics.Internal.Profunctor.Lens import Data.Generics.Internal.Profunctor.Iso import Data.Generics.Internal.Profunctor.Prism data Animal = Animal { name :: String , age :: Int , eats :: String } deriving (Show, Generic) data Human = Human { name :: String , age :: Int , address :: String , eats :: String } deriving (Show, Generic) data Living = Animal' { name :: String, eats :: String, age :: Int } | Human' { name :: String, age :: Int, address :: String, eats :: String } deriving (Show, Generic) toby :: Human toby = Human { name = "Toby", age = 10, address = "London", eats = "Bread" } growUp :: Animal -> Animal growUp (Animal n a _) = Animal n (a + 10) "raw meat" data MyRecord = MyRecord { field1 :: Int, field2 :: String } deriving Generic --g :: Subtype s MyRecord => s -> String --g s = s ^. super @MyRecord . label @"field2" data Test a b = Test { fieldInt :: Int, fieldA :: a, fieldB :: b } deriving (Generic, Show) -- | changedA :: Test Int String -- >>> changedA -- Test {fieldInt = 10, fieldA = 10, fieldB = "world"} changedA = Test 10 "hello" "world" & field @"fieldA" .~ (10 :: Int) -- | changedB :: Test String Int -- >>> changedB -- Test {fieldInt = 10, fieldA = "hello", fieldB = 10} changedB = (Test 10 "hello" "world") & field @"fieldB" .~ (10 :: Int) data Animal2 a = Dog (Dog a) | Cat Name Age | Duck Age deriving (Generic, Show) data Dog a = MkDog { name :: Name , age :: Age , fieldA :: a } deriving (Generic, Show) type Name = String type Age = Int dog :: Animal2 Int dog = Dog (MkDog "Shep" 3 30) -- TODO: the error message for this case is ugly -- data Dog a -- = MkDog -- { name :: Name -- , age :: Age -- , fieldA :: a -- , fieldA' :: a -- } -- deriving (Generic, Show) -- | -- >>> :t dog' -- dog' :: Animal2 [Char] dog' = dog & _Ctor @"Dog" . field @"fieldA" .~ "now it's a String" stuff :: ( HasPosition 15 s t a String , HasField "test" s' t' a' b' , HasField "bar" a' b' s t ) => s' -> t' stuff r = r & field @"test" . field @"bar" . position @15 .~ "hello" stuff' :: ( HasPosition 15 s t a String , HasField "test" s' t' a' b' , HasField "bar" a' b' s t ) => s' -> t' stuff' r = r & #test . #bar . position @15 .~ "hello" data Foo m s = Foo { foo1 :: m s , foo2 :: [s] } deriving Generic modifyFoo2 :: Foo (Either String) Int -> Foo Maybe Int modifyFoo2 x = x & field @"foo1" .~ pure (1 :: Int) data Bar a b = Bar { barField :: (a, b) } deriving Generic modifiedBar = (Bar ("hello", "world")) & field @"barField" .~ ('c', 1 :: Int) generic-lens-2.2.2.0/examples/StarWars.hs0000644000000000000000000000337207346545000016344 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -- Note: this file may contain spoilers -- (although I would be really surprised if it did, I haven't seen the films) module StarWars where import GHC.Generics import Data.Generics.Product data Episode = NEWHOPE | EMPIRE | JEDI deriving (Generic, Show, Eq) data Character = Character { name :: String , friends :: [Character] , appearsIn :: [Episode] } deriving (Generic, Show, Eq) data Human = Human { name :: String , friends :: [Character] , appearsIn :: [Episode] , homePlanet :: String } deriving (Generic, Show) data Droid = Droid { friends :: [Character] , appearsIn :: [Episode] , name :: String , primaryFunction :: String } deriving (Generic, Show) luke :: Human luke = Human { name = "Luke Skywalker" , friends = [] , appearsIn = [NEWHOPE, EMPIRE, JEDI] , homePlanet = "Saturn (?)" } r2d2 :: Droid r2d2 = Droid { name = "R2-D2" , friends = [upcast luke] , appearsIn = [NEWHOPE, EMPIRE, JEDI] , primaryFunction = "repair ships" } c3po :: Droid c3po = Droid { name = "C3PO" , friends = [upcast r2d2, upcast luke] , appearsIn = [NEWHOPE, EMPIRE, JEDI] , primaryFunction = "protocol and human relations" } getName :: HasField' "name" r a => r -> a getName = getField @"name" -- upcast :: Subtype a b => a -> b characters :: [Character] characters = [upcast r2d2, upcast luke, upcast c3po] names :: [String] names = map getName characters -- => ["R2-D2","Luke Skywalker","C3PO"] generic-lens-2.2.2.0/examples/doctest.hs0000644000000000000000000000011607346545000016234 0ustar0000000000000000import Test.DocTest main = doctest [ "src" , "examples" ] generic-lens-2.2.2.0/generic-lens.cabal0000644000000000000000000000757207346545000015771 0ustar0000000000000000name: generic-lens version: 2.2.2.0 synopsis: Generically derive traversals, lenses and prisms. description: This library uses GHC.Generics to derive efficient optics (traversals, lenses and prisms) for algebraic data types in a type-directed way, with a focus on good type inference and error messages when possible. . The library exposes a van Laarhoven interface. For an alternative interface, supporting an opaque optic type, see @@. homepage: https://github.com/kcsongor/generic-lens license: BSD3 license-file: LICENSE author: Csongor Kiss maintainer: kiss.csongor.kiss@gmail.com category: Generics, Records, Lens build-type: Simple cabal-version: >= 1.10 Tested-With: GHC == 8.4.1, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.3, GHC == 9.0.1, GHC == 9.2.1 extra-source-files: examples/StarWars.hs , examples/Examples.hs , ChangeLog.md library exposed-modules: Data.Generics.Wrapped , Data.Generics.Product , Data.Generics.Product.Any , Data.Generics.Product.Fields , Data.Generics.Product.Param , Data.Generics.Product.Positions , Data.Generics.Product.Subtype , Data.Generics.Product.Typed , Data.Generics.Product.Types , Data.Generics.Product.HList , Data.Generics.Labels , Data.Generics.Sum , Data.Generics.Sum.Any , Data.Generics.Sum.Constructors , Data.Generics.Sum.Typed , Data.Generics.Sum.Subtype , Data.Generics.Internal.VL , Data.Generics.Internal.VL.Lens , Data.Generics.Internal.VL.Prism , Data.Generics.Internal.VL.Iso build-depends: base >= 4.11 && < 5 , generic-lens-core == 2.2.1.0 , profunctors , text >= 1.2 && < 1.3 || >= 2.0 && < 2.1 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall test-suite inspection-tests type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs other-modules: Util Test24 Test88 Test25 Test40 Test62 Test63 CustomChildren build-depends: base >= 4.11 && <= 5.0 , generic-lens , lens , profunctors , inspection-testing >= 0.2 , HUnit default-language: Haskell2010 ghc-options: -Wall test-suite generic-lens-bifunctor type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Bifunctor.hs build-depends: base >= 4.11 && <= 5.0 , generic-lens , lens , HUnit default-language: Haskell2010 ghc-options: -Wall test-suite generic-lens-syb-tree type: exitcode-stdio-1.0 hs-source-dirs: test/syb main-is: Tree.hs build-depends: base >= 4.11 && <= 5.0 , generic-lens , lens , profunctors , HUnit default-language: Haskell2010 ghc-options: -Wall test-suite doctests default-language: Haskell2010 type: exitcode-stdio-1.0 ghc-options: -threaded main-is: doctest.hs build-depends: base >4 && <5 , doctest , lens hs-source-dirs: examples generic-lens-2.2.2.0/src/Data/Generics/Internal/0000755000000000000000000000000007346545000017372 5ustar0000000000000000generic-lens-2.2.2.0/src/Data/Generics/Internal/VL.hs0000644000000000000000000000061507346545000020251 0ustar0000000000000000{-# LANGUAGE PackageImports #-} module Data.Generics.Internal.VL ( module Lens , module Iso , module Prism , module Traversal ) where import "this" Data.Generics.Internal.VL.Lens as Lens import "this" Data.Generics.Internal.VL.Iso as Iso import "this" Data.Generics.Internal.VL.Prism as Prism import "generic-lens-core" Data.Generics.Internal.VL.Traversal as Traversal generic-lens-2.2.2.0/src/Data/Generics/Internal/VL/0000755000000000000000000000000007346545000017713 5ustar0000000000000000generic-lens-2.2.2.0/src/Data/Generics/Internal/VL/Iso.hs0000644000000000000000000000567007346545000021011 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Internal.VL.Iso -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Internal lens helpers. Only exported for Haddock -- ----------------------------------------------------------------------------- module Data.Generics.Internal.VL.Iso where import Data.Coerce (coerce) import Data.Functor.Identity (Identity(..)) import Data.Profunctor import GHC.Generics import Data.Generics.Internal.GenericN (Rec (..), GenericN (..), Param (..)) import qualified Data.Generics.Internal.Profunctor.Iso as P data Exchange a b s t = Exchange (s -> a) (b -> t) instance Functor (Exchange a b s) where fmap f (Exchange p q) = Exchange p (f . q) {-# INLINE fmap #-} instance Profunctor (Exchange a b) where dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt) {-# INLINE dimap #-} lmap f (Exchange sa bt) = Exchange (sa . f) bt {-# INLINE lmap #-} rmap f (Exchange sa bt) = Exchange sa (f . bt) {-# INLINE rmap #-} type Iso' s a = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s) type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) fromIso :: Iso s t a b -> Iso b a t s fromIso l = withIso l $ \ sa bt -> iso bt sa {-# inline fromIso #-} iso2isovl :: P.Iso s t a b -> Iso s t a b iso2isovl _iso = P.withIso _iso $ \ sa bt -> iso sa bt {-# INLINE iso2isovl #-} -- | Extract the two functions, one from @s -> a@ and -- one from @b -> t@ that characterize an 'Iso'. withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r withIso ai k = case ai (Exchange id Identity) of Exchange sa bt -> k sa (coerce bt) {-# inline withIso #-} -- | A type and its generic representation are isomorphic repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x) repIso = iso from to repIsoN :: (GenericN a, GenericN b) => Iso a b (RepN a x) (RepN b x) repIsoN = iso fromN toN paramIso :: Iso (Param n a) (Param n b) a b paramIso = iso getStarParam StarParam -- | 'M1' is just a wrapper around `f p` mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p) mIso = iso unM1 M1 kIso :: Iso (K1 r a p) (K1 r b p) a b kIso = iso unK1 K1 recIso :: Iso (Rec r a p) (Rec r b p) a b recIso = iso (unK1 . unRec) (Rec . K1) prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x) prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b)) iso :: (s -> a) -> (b -> t) -> Iso s t a b iso sa bt = dimap sa (fmap bt) {-# INLINE iso #-} generic-lens-2.2.2.0/src/Data/Generics/Internal/VL/Lens.hs0000644000000000000000000000406107346545000021151 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Internal.VL.Lens -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Internal lens helpers. Only exported for Haddock -- ----------------------------------------------------------------------------- module Data.Generics.Internal.VL.Lens where import "generic-lens-core" Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens) import Control.Applicative (Const(..)) import Data.Coerce (coerce) import Data.Functor.Identity (Identity(..)) -- | Type alias for lens type Lens' s a = Lens s s a a type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t view :: ((a -> Const a a) -> s -> Const a s) -> s -> a view l s = (^.) s l -- | Getting (^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a s ^. l = getConst (l Const s) infixl 8 ^. infixr 4 .~ (.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t (.~) f b = runIdentity . f (Identity . const b) set :: Lens s t a b -> b -> s -> t set l x = l .~ x over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t over = coerce lens2lensvl :: ALens a b i s t -> Lens s t a b lens2lensvl (ALens _get _set) = \f x -> case _get x of (c, a) -> _set . (c, ) <$> f a {-# INLINE lens2lensvl #-} ravel :: (ALens a b i a b -> ALens a b i s t) -> Lens s t a b ravel l pab = (lens2lensvl $ l idLens) pab lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b lens get _set = \f x -> _set x <$> f (get x) {-# INLINE lens #-} generic-lens-2.2.2.0/src/Data/Generics/Internal/VL/Prism.hs0000644000000000000000000000545507346545000021352 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Internal.VL.Prism -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Internal lens helpers. Only exported for Haddock -- ----------------------------------------------------------------------------- module Data.Generics.Internal.VL.Prism where import qualified "generic-lens-core" Data.Generics.Internal.Profunctor.Prism as P import qualified Data.Profunctor as P import Data.Functor.Identity (Identity (..)) import Data.Coerce (coerce) -- | Type alias for prism type Prism s t a b = forall p f. (P.Choice p, Applicative f) => p a (f b) -> p s (f t) type Prism' s a = Prism s s a a match :: Prism s t a b -> s -> Either t a match p = case p (Market Identity Right) of Market _ seta -> coerce seta {-# INLINE match #-} build :: Prism s t a b -> b -> t build p = case p (Market Identity Right) of Market bt _ -> coerce bt {-# INLINE build #-} prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b prism bt seta eta = P.dimap (\x -> P.left' pure (seta x)) (either id (\x -> fmap bt x)) (P.right' eta) {-# INLINE prism #-} prism2prismvl :: P.APrism i s t a b -> Prism s t a b prism2prismvl _prism = P.withPrism _prism $ \ bt sta -> prism bt sta {-# INLINE prism2prismvl #-} -------------------------------------------------------------------------------- -- Market data Market a b s t = Market (b -> t) (s -> Either t a) instance Functor (Market a b s) where fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) {-# INLINE fmap #-} instance P.Profunctor (Market a b) where dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f) {-# INLINE dimap #-} lmap f (Market bt seta) = Market bt (seta . f) {-# INLINE lmap #-} rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) {-# INLINE rmap #-} instance P.Choice (Market a b) where left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of Left s -> case seta s of Left t -> Left (Left t) Right a -> Right a Right c -> Left (Right c) {-# INLINE left' #-} right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of Left c -> Left (Left c) Right s -> case seta s of Left t -> Left (Right t) Right a -> Right a {-# INLINE right' #-} generic-lens-2.2.2.0/src/Data/Generics/0000755000000000000000000000000007346545000015616 5ustar0000000000000000generic-lens-2.2.2.0/src/Data/Generics/Labels.hs0000644000000000000000000001271707346545000017364 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Generics.Labels -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Provides an (orphan) IsLabel instance for field lenses and constructor prisms. -- Use at your own risk. -------------------------------------------------------------------------------- module Data.Generics.Labels ( -- * Orphan IsLabel Instance -- $sec1 Field(..) , Field' , Constructor(..) , Constructor' ) where import "this" Data.Generics.Product import "this" Data.Generics.Sum import "this" Data.Generics.Internal.VL.Lens (Lens) import "this" Data.Generics.Internal.VL.Prism (Prism) import Data.Profunctor (Choice) import Data.Type.Bool (type (&&), If) import Data.Type.Equality (type (==)) import GHC.OverloadedLabels import GHC.TypeLits -- $sec1 -- An instance for creating lenses and prisms with @#identifiers@ from the -- @OverloadedLabels@ extension. Note that since overloaded labels did not -- support symbols starting with capital letters, all prisms (which come from -- constructor names, which are capitalized) must be prefixed with an underscore -- (e.g. @#_ConstructorName@) when you use a GHC older than 9.6. -- -- Morally: -- -- @ -- instance (HasField name s t a b) => IsLabel name (Lens s t a b) where ... -- @ -- and -- -- @ -- instance (AsConstructor name s t a b) => IsLabel name (Prism s t a b) where ... -- @ -- -- Remember: -- -- @ -- type Lens = forall f. Functor f => (a -> f b) -> s -> f t -- -- type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) -- @ -- -- The orphan instance is unavoidable if we want to work with -- lenses-as-functions (as opposed to a 'ReifiedLens'-like newtype). -- | 'Field' is morally the same as 'HasField', but it is constructed from an -- incoherent combination of 'HasField' and 'HasField''. In this way, it can be -- seamlessly used in the 'IsLabel' instance even when dealing with data types -- that don't have 'Field' instances (like data instances). class Field name s t a b | s name -> a, t name -> b, s name b -> t, t name a -> s where fieldLens :: Lens s t a b type Field' name s a = Field name s s a a instance {-# INCOHERENT #-} HasField name s t a b => Field name s t a b where fieldLens = field @name instance {-# INCOHERENT #-} HasField' name s a => Field name s s a a where fieldLens = field' @name -- | 'Constructor' is morally the same as 'AsConstructor', but it is constructed from an -- incoherent combination of 'AsConstructor' and 'AsConstructor''. In this way, it can be -- seamlessly used in the 'IsLabel' instance even when dealing with data types -- that don't have 'Constructor' instances (like data instances). class Constructor name s t a b | name s -> a, name t -> b where constructorPrism :: Prism s t a b type Constructor' name s a = Constructor name s s a a instance {-# INCOHERENT #-} AsConstructor name s t a b => Constructor name s t a b where constructorPrism = _Ctor @name instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where constructorPrism = _Ctor' @name data LabelType = FieldType | LegacyConstrType | ConstrType type family ClassifyLabel (name :: Symbol) :: LabelType where ClassifyLabel name = If (CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT) 'LegacyConstrType ( If (CmpSymbol "@" name == 'LT && CmpSymbol "[" name == 'GT) 'ConstrType 'FieldType ) instance ( labelType ~ ClassifyLabel name , IsLabelHelper labelType name p f s t a b , pafb ~ p a (f b), psft ~ p s (f t)) => IsLabel name (pafb -> psft) where fromLabel = labelOutput @labelType @name @p @f -- | This helper class allows us to customize the output type of the lens to be -- either 'Prism' or 'Lens' (by choosing appropriate @p@ and @f@) as well as to -- choose between whether we're dealing with a lens or a prism. The choice is -- made by the @labelType@ argument, which is determined by whether the symbol -- starts with a capital letter, optionally preceded by an underscore (a check -- done in the 'IsLabel' instance above). If so, then we're dealing with a -- constructor name, which should be a prism, and otherwise, it's a field name, -- so we have a lens. class IsLabelHelper labelType name p f s t a b where labelOutput :: p a (f b) -> p s (f t) instance (Functor f, Field name s t a b) => IsLabelHelper 'FieldType name (->) f s t a b where labelOutput = fieldLens @name instance ( Applicative f, Choice p, Constructor name s t a b , name' ~ AppendSymbol "_" name) => IsLabelHelper 'LegacyConstrType name' p f s t a b where labelOutput = constructorPrism @name instance ( Applicative f, Choice p, Constructor name s t a b ) => IsLabelHelper 'ConstrType name p f s t a b where labelOutput = constructorPrism @name generic-lens-2.2.2.0/src/Data/Generics/Product.hs0000644000000000000000000000254607346545000017601 0ustar0000000000000000{-# LANGUAGE PackageImports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Magic product operations using Generics -- -- These classes need not be instantiated manually, as GHC can automatically -- prove valid instances via Generics. Only the `Generic` class needs to -- be derived (see examples). -- ----------------------------------------------------------------------------- module Data.Generics.Product ( -- *Lenses module Data.Generics.Product.Any , module Data.Generics.Product.Fields , module Data.Generics.Product.Positions , module Data.Generics.Product.Subtype , module Data.Generics.Product.Typed , module Data.Generics.Product.HList -- *Traversals , module Data.Generics.Product.Types , module Data.Generics.Product.Param ) where import "this" Data.Generics.Product.Any import "this" Data.Generics.Product.Fields import "this" Data.Generics.Product.Positions import "this" Data.Generics.Product.Subtype import "this" Data.Generics.Product.Typed import "this" Data.Generics.Product.Types import "this" Data.Generics.Product.Param import "this" Data.Generics.Product.HList generic-lens-2.2.2.0/src/Data/Generics/Product/0000755000000000000000000000000007346545000017236 5ustar0000000000000000generic-lens-2.2.2.0/src/Data/Generics/Product/Any.hs0000644000000000000000000000426207346545000020325 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Any -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Derive a variety of lenses generically. -- ----------------------------------------------------------------------------- module Data.Generics.Product.Any ( -- *Lenses -- -- $setup HasAny (..) ) where import "this" Data.Generics.Internal.VL.Lens import "this" Data.Generics.Product.Fields import "this" Data.Generics.Product.Positions import "this" Data.Generics.Product.Typed -- $setup -- == /Running example:/ -- -- >>> :set -XTypeApplications -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics -- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :{ -- data Human = Human -- { name :: String -- , age :: Int -- , address :: String -- } -- deriving (Generic, Show) -- human :: Human -- human = Human "Tunyasz" 50 "London" -- :} class HasAny sel s t a b | s sel -> a where -- |A lens that focuses on a part of a product as identified by some -- selector. Currently supported selectors are field names, positions and -- unique types. Compatible with the lens package's 'Control.Lens.Lens' -- type. -- -- >>> human ^. the @Int -- 50 -- -- >>> human ^. the @"name" -- "Tunyasz" -- -- >>> human ^. the @3 -- "London" the :: Lens s t a b instance HasPosition i s t a b => HasAny i s t a b where the = position @i instance HasField field s t a b => HasAny field s t a b where the = field @field instance (HasType a s, t ~ s, a ~ b) => HasAny a s t a b where the = typed @a generic-lens-2.2.2.0/src/Data/Generics/Product/Fields.hs0000644000000000000000000001242107346545000021000 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Fields -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Derive record field getters and setters generically. -- ----------------------------------------------------------------------------- module Data.Generics.Product.Fields ( -- *Lenses -- $setup HasField (..) , HasField' (..) , HasField_ (..) , getField , setField ) where import "this" Data.Generics.Internal.VL.Lens as VL import "generic-lens-core" Data.Generics.Internal.Void import qualified "generic-lens-core" Data.Generics.Product.Internal.Fields as Core import GHC.TypeLits (Symbol) -- $setup -- == /Running example:/ -- -- >>> :set -XTypeApplications -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> :set -XGADTs -- >>> :set -XFlexibleContexts -- >>> import GHC.Generics -- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :m +Data.Function -- >>> :{ -- data Human a -- = Human -- { name :: String -- , age :: Int -- , address :: String -- , other :: a -- } -- | HumanNoAddress -- { name :: String -- , age :: Int -- , other :: a -- } -- deriving (Generic, Show) -- human :: Human Bool -- human = Human { name = "Tunyasz", age = 50, address = "London", other = False } -- :} -- |Records that have a field with a given name. class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b -> t, t field a -> s where -- |A lens that focuses on a field with a given name. Compatible with the -- lens package's 'Control.Lens.Lens' type. -- -- >>> human ^. field @"age" -- 50 -- -- === /Type changing/ -- -- >>> :t human -- human :: Human Bool -- -- >>> :t human & field @"other" .~ (42 :: Int) -- human & field @"other" .~ (42 :: Int) :: Human Int -- -- >>> human & field @"other" .~ 42 -- Human {name = "Tunyasz", age = 50, address = "London", other = 42} -- -- === /Type errors/ -- -- >>> human & field @"weight" .~ 42 -- ... -- ... The type Human Bool does not contain a field named 'weight'. -- ... -- -- >>> human & field @"address" .~ "" -- ... -- ... Not all constructors of the type Human Bool -- ... contain a field named 'address'. -- ... The offending constructors are: -- ... HumanNoAddress -- ... field :: VL.Lens s t a b -- |Records that have a field with a given name. -- -- This is meant to be more general than 'HasField', but that is not quite the -- case due to the lack of functional dependencies. -- -- The types @s@ and @t@ must be applications of the same type constructor. -- In contrast, 'HasField' also requires the parameters of that type constructor -- to have representational roles. -- -- One use case of 'HasField_' over 'HasField' is for records defined with -- @data instance@. class HasField_ (field :: Symbol) s t a b where field_ :: VL.Lens s t a b class HasField' (field :: Symbol) s a | s field -> a where field' :: VL.Lens s s a a -- |Records that have a field with a given name. -- -- This class gives the minimal constraints needed to define this lens. -- For common uses, see 'HasField'. class HasField0 (field :: Symbol) s t a b where field0 :: VL.Lens s t a b -- | -- >>> getField @"age" human -- 50 getField :: forall f a s. HasField' f s a => s -> a getField = VL.view (field' @f) -- | -- >>> setField @"age" 60 human -- Human {name = "Tunyasz", age = 60, address = "London", other = False} setField :: forall f s a. HasField' f s a => a -> s -> s setField = VL.set (field' @f) instance Core.Context' field s a => HasField' field s a where field' f s = field0 @field f s instance (Core.Context field s t a b , HasField0 field s t a b) => HasField field s t a b where field f s = field0 @field f s -- instance {-# OVERLAPPING #-} HasField' field s a => HasField field s s a a where -- field f s = field' @field f s -- | Uncluttering type signatures (see 'Void') -- -- >>> :t +d field -- field -- :: (HasField field s t a b, Functor f) => (a -> f b) -> s -> f t instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where field = undefined instance {-# OVERLAPPING #-} HasField' f (Void1 a) a where field' = undefined instance (Core.Context_ field s t a b , HasField0 field s t a b) => HasField_ field s t a b where field_ f s = field0 @field f s instance {-# OVERLAPPING #-} HasField_ f (Void1 a) (Void1 b) a b where field_ = undefined instance Core.Context0 field s t a b => HasField0 field s t a b where field0 = VL.ravel (Core.derived @field) {-# INLINE field0 #-} generic-lens-2.2.2.0/src/Data/Generics/Product/HList.hs0000644000000000000000000000266307346545000020624 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.HList -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Derive an isomorphism between a product type and a flat HList. -- ----------------------------------------------------------------------------- module Data.Generics.Product.HList ( IsList (..) ) where import "this" Data.Generics.Internal.VL.Iso (Iso, iso2isovl) import "generic-lens-core" Data.Generics.Internal.Profunctor.Iso (repIso) import qualified "generic-lens-core" Data.Generics.Product.Internal.HList as Core import Data.Kind import GHC.Generics class IsList (f :: Type) (g :: Type) (as :: [Type]) (bs :: [Type]) | f -> as, g -> bs where list :: Iso f g (Core.HList as) (Core.HList bs) instance ( Generic f , Generic g , Core.GIsList (Rep f) (Rep g) as bs ) => IsList f g as bs where list = iso2isovl (repIso . Core.glist) {-# INLINE list #-} generic-lens-2.2.2.0/src/Data/Generics/Product/Param.hs0000644000000000000000000000342207346545000020633 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Param -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Derive traversals over type parameters -- -------------------------------------------------------------------------------- module Data.Generics.Product.Param ( Rec (Rec) -- TODO: this has to be re-exported so the constructor is visible for Coercible... is there a better way? , HasParam (..) , Param (..) ) where import "generic-lens-core" Data.Generics.Internal.VL.Traversal import qualified "generic-lens-core" Data.Generics.Product.Internal.Param as Core import "generic-lens-core" Data.Generics.Internal.GenericN import "generic-lens-core" Data.Generics.Internal.Void import GHC.TypeLits class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where param :: Traversal s t a b instance Core.Context n s t a b => HasParam n s t a b where param = confusing (Core.derived @n) {-# INLINE param #-} instance {-# OVERLAPPING #-} HasParam p (Void1 a) (Void1 b) a b where param = undefined generic-lens-2.2.2.0/src/Data/Generics/Product/Positions.hs0000644000000000000000000001072007346545000021561 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Positions -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Derive positional product type getters and setters generically. -- ----------------------------------------------------------------------------- module Data.Generics.Product.Positions ( -- *Lenses -- $setup HasPosition (..) , HasPosition' (..) , HasPosition_ (..) , HasPosition0 (..) , getPosition , setPosition ) where import "this" Data.Generics.Internal.VL.Lens as VL import "generic-lens-core" Data.Generics.Internal.Void import qualified "generic-lens-core" Data.Generics.Product.Internal.Positions as Core import GHC.TypeLits (Nat) -- $setup -- == /Running example:/ -- -- >>> :set -XTypeApplications -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> :set -XGADTs -- >>> :set -XFlexibleContexts -- >>> import GHC.Generics -- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :m +Data.Function -- >>> :{ -- data Human = Human -- { name :: String -- , age :: Int -- , address :: String -- } -- deriving (Generic, Show) -- human :: Human -- human = Human "Tunyasz" 50 "London" -- :} -- |Records that have a field at a given position. class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a -> s where -- |A lens that focuses on a field at a given position. Compatible with the -- lens package's 'Control.Lens.Lens' type. -- -- >>> human ^. position @1 -- "Tunyasz" -- >>> human & position @3 .~ "Berlin" -- Human {name = "Tunyasz", age = 50, address = "Berlin"} -- -- === /Type errors/ -- -- >>> human & position @4 .~ "Berlin" -- ... -- ... The type Human does not contain a field at position 4 -- ... position :: VL.Lens s t a b class HasPosition_ (i :: Nat) s t a b where position_ :: VL.Lens s t a b -- |Records that have a field at a given position. -- -- The difference between 'HasPosition' and 'HasPosition_' is similar to the -- one between 'Data.Generics.Product.Fields.HasField' and -- 'Data.Generics.Product.Fields.HasField_'. -- See 'Data.Generics.Product.Fields.HasField_'. class HasPosition' (i :: Nat) s a | s i -> a where position' :: VL.Lens s s a a -- |Records that have a field at a given position. -- -- This class gives the minimal constraints needed to define this lens. -- For common uses, see 'HasPosition'. class HasPosition0 (i :: Nat) s t a b where position0 :: VL.Lens s t a b -- | -- >>> getPosition @2 human -- 50 getPosition :: forall i s a. HasPosition' i s a => s -> a getPosition s = s ^. position' @i -- | -- >>> setPosition @2 60 human -- Human {name = "Tunyasz", age = 60, address = "London"} setPosition :: forall i s a. HasPosition' i s a => a -> s -> s setPosition = VL.set (position' @i) instance Core.Context' i s a => HasPosition' i s a where position' f s = VL.ravel (Core.derived' @i) f s {-# INLINE position' #-} instance (Core.Context i s t a b , HasPosition0 i s t a b) => HasPosition i s t a b where position = position0 @i {-# INLINE position #-} -- | Uncluttering type signatures (see 'Void') -- -- >>> :t +d position -- position -- :: (HasPosition i s t a b, Functor f) => (a -> f b) -> s -> f t instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where position = undefined instance (Core.Context_ i s t a b, HasPosition0 i s t a b) => HasPosition_ i s t a b where position_ = position0 @i {-# INLINE position_ #-} instance {-# OVERLAPPING #-} HasPosition_ f (Void1 a) (Void1 b) a b where position_ = undefined instance Core.Context0 i s t a b => HasPosition0 i s t a b where position0 f s = VL.ravel (Core.derived0 @i) f s {-# INLINE position0 #-} generic-lens-2.2.2.0/src/Data/Generics/Product/Subtype.hs0000644000000000000000000000743007346545000021231 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Subtype -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Structural subtype relationships between product types. -- ----------------------------------------------------------------------------- module Data.Generics.Product.Subtype ( -- *Lenses -- -- $setup Subtype (..) ) where import "this" Data.Generics.Internal.VL.Lens as VL import "generic-lens-core" Data.Generics.Internal.Void import qualified "generic-lens-core" Data.Generics.Product.Internal.Subtype as Core import GHC.Generics (Generic (to, from) ) -- $setup -- == /Running example:/ -- -- >>> :set -XTypeApplications -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> :set -XDuplicateRecordFields -- >>> import GHC.Generics -- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :{ -- data Human = Human -- { name :: String -- , age :: Int -- , address :: String -- } -- deriving (Generic, Show) -- data Animal = Animal -- { name :: String -- , age :: Int -- } -- deriving (Generic, Show) -- human :: Human -- human = Human "Tunyasz" 50 "London" -- :} -- |Structural subtype relationship -- -- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of -- those of @sup@. -- class Subtype sup sub where -- |Structural subtype lens. Given a subtype relationship @sub :< sup@, -- we can focus on the @sub@ structure of @sup@. -- -- >>> human ^. super @Animal -- Animal {name = "Tunyasz", age = 50} -- -- >>> set (super @Animal) (Animal "dog" 10) human -- Human {name = "dog", age = 10, address = "London"} super :: VL.Lens sub sub sup sup super = VL.lens upcast (flip smash) {-# INLINE super #-} -- |Cast the more specific subtype to the more general supertype -- -- >>> upcast human :: Animal -- Animal {name = "Tunyasz", age = 50} -- -- >>> upcast (upcast human :: Animal) :: Human -- ... -- ... The type 'Animal' is not a subtype of 'Human'. -- ... The following fields are missing from 'Animal': -- ... address -- ... upcast :: sub -> sup upcast s = s ^. super @sup {-# INLINE upcast #-} -- |Plug a smaller structure into a larger one -- -- >>> smash (Animal "dog" 10) human -- Human {name = "dog", age = 10, address = "London"} smash :: sup -> sub -> sub smash = VL.set (super @sup) {-# INLINE smash #-} {-# MINIMAL super | smash, upcast #-} instance Core.Context a b => Subtype b a where smash p b = to $ Core.gsmash (from p) (from b) upcast = to . Core.gupcast . from instance {-# OVERLAPPING #-} Subtype a a where super = id -- | Uncluttering type signatures (see 'Void') -- -- >>> :t +d super -- super -- :: (Subtype sup sub, Functor f) => (sup -> f sup) -> sub -> f sub instance {-# OVERLAPPING #-} Subtype a Void where super = undefined -- | Uncluttering type signatures (see 'Void') -- -- >>> :t +d super @Int -- super @Int -- :: (Subtype Int sub, Functor f) => (Int -> f Int) -> sub -> f sub instance {-# OVERLAPPING #-} Subtype Void a where super = undefined generic-lens-2.2.2.0/src/Data/Generics/Product/Typed.hs0000644000000000000000000000606707346545000020670 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Typed -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Derive lenses of a given type in a product. -- ----------------------------------------------------------------------------- module Data.Generics.Product.Typed ( -- *Lenses -- -- $setup HasType (..) ) where import "this" Data.Generics.Internal.VL.Lens as VL import qualified "generic-lens-core" Data.Generics.Product.Internal.Typed as Core import "generic-lens-core" Data.Generics.Internal.Void -- $setup -- == /Running example:/ -- -- >>> :set -XTypeApplications -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics -- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :{ -- data Human -- = Human -- { name :: String -- , age :: Int -- , address :: String -- , tall :: Bool -- } -- | HumanNoTall -- { name :: String -- , age :: Int -- , address :: String -- } -- deriving (Generic, Show) -- human :: Human -- human = Human "Tunyasz" 50 "London" False -- :} -- |Records that have a field with a unique type. class HasType a s where -- |A lens that focuses on a field with a unique type in its parent type. -- Compatible with the lens package's 'Control.Lens.Lens' type. -- -- >>> human ^. typed @Int -- 50 -- -- === /Type errors/ -- -- >>> human ^. typed @String -- ... -- ... -- ... The type Human contains multiple values of type [Char]. -- ... The choice of value is thus ambiguous. The offending constructors are: -- ... Human -- ... HumanNoTall -- ... -- -- >>> human ^. typed @Bool -- ... -- ... -- ... Not all constructors of the type Human contain a field of type Bool. -- ... The offending constructors are: -- ... HumanNoTall -- ... typed :: VL.Lens s s a a typed = VL.lens (getTyped @a) (flip (setTyped @a)) {-# INLINE typed #-} -- |Get field at type. getTyped :: s -> a getTyped s = s ^. typed @a -- |Set field at type. setTyped :: a -> s -> s setTyped = VL.set (typed @a) {-# MINIMAL typed | setTyped, getTyped #-} instance Core.Context a s => HasType a s where typed = VL.ravel Core.derived {-# INLINE typed #-} instance {-# OVERLAPPING #-} HasType a a where getTyped = id {-# INLINE getTyped #-} setTyped a _ = a {-# INLINE setTyped #-} -- | Uncluttering type signatures (see 'Void') -- -- >>> :t +d typed -- typed :: (HasType a s, Functor f) => (a -> f a) -> s -> f s -- -- Note that this might not longer be needed given the 'HasType a a' instance. instance {-# OVERLAPPING #-} HasType a Void where typed = undefined generic-lens-2.2.2.0/src/Data/Generics/Product/Types.hs0000644000000000000000000000731707346545000020706 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Types -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Derive traversals of a given type in a product. -- ----------------------------------------------------------------------------- module Data.Generics.Product.Types ( -- *Traversals -- -- $setup Core.HasTypes , types -- * Custom traversal strategies -- $custom , Core.Children , Core.ChGeneric , Core.HasTypesUsing , typesUsing , Core.HasTypesCustom (typesCustom) ) where import qualified "generic-lens-core" Data.Generics.Internal.VL.Traversal as VL import qualified "generic-lens-core" Data.Generics.Product.Internal.Types as Core -- $setup -- == /Running example:/ -- -- >>> :set -XTypeApplications -- >>> :set -XDeriveGeneric -- >>> :set -XScopedTypeVariables -- >>> import GHC.Generics -- >>> :m +Data.Generics.Internal.VL.Traversal -- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :{ -- data WTree a w -- = Leaf a -- | Fork (WTree a w) (WTree a w) -- | WithWeight (WTree a w) w -- deriving (Generic, Show) -- :} -------------------------------------------------------------------------------- -- HasTypes -------------------------------------------------------------------------------- -- | Traverse all types in the given structure. -- -- For example, to update all 'String's in a @WTree (Maybe String) String@, we can write -- -- >>> myTree = WithWeight (Fork (Leaf (Just "hello")) (Leaf Nothing)) "world" -- >>> over (types @String) (++ "!") myTree -- WithWeight (Fork (Leaf (Just "hello!")) (Leaf Nothing)) "world!" -- -- The traversal is /deep/, which means that not just the immediate -- children are visited, but all nested values too. types :: forall a s. Core.HasTypes s a => VL.Traversal' s a types = VL.confusing (Core.types_ @s @a) {-# INLINE types #-} -------------------------------------------------------------------------------- -- HasTypesUsing -------------------------------------------------------------------------------- -- $custom -- -- The default traversal strategy 'types' recurses into each node of the type -- using the 'Generic' instance for the nodes. However, in general not all -- nodes will have a 'Generic' instance. For example: -- -- >>> data Opaque = Opaque String deriving Show -- >>> myTree = WithWeight (Fork (Leaf (Opaque "foo")) (Leaf (Opaque "bar"))) False -- >>> over (types @String) (++ "!") myTree -- ... -- ... | No instance for ‘Generic Opaque’ -- ... | arising from a generic traversal. -- ... | Either derive the instance, or define a custom traversal using HasTypesCustom -- ... -- -- In these cases, we can define a custom traversal strategy to override the -- generic behaviour for certain types. -- For a self-contained example, see the CustomChildren module in the tests directory. -- | @since 1.2.0.0 typesUsing :: forall ch a s. Core.HasTypesUsing ch s s a a => VL.Traversal' s a typesUsing = VL.confusing (Core.typesUsing_ @ch @s @s @a) {-# INLINE typesUsing #-} generic-lens-2.2.2.0/src/Data/Generics/Sum.hs0000644000000000000000000000175107346545000016722 0ustar0000000000000000{-# LANGUAGE PackageImports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Magic sum operations using Generics -- -- These classes need not be instantiated manually, as GHC can automatically -- prove valid instances via Generics. Only the `Generic` class needs to -- be derived (see examples). -- ----------------------------------------------------------------------------- module Data.Generics.Sum ( -- *Prisms module Data.Generics.Sum.Any , module Data.Generics.Sum.Constructors , module Data.Generics.Sum.Subtype , module Data.Generics.Sum.Typed ) where import "this" Data.Generics.Sum.Any import "this" Data.Generics.Sum.Constructors import "this" Data.Generics.Sum.Subtype import "this" Data.Generics.Sum.Typed generic-lens-2.2.2.0/src/Data/Generics/Sum/0000755000000000000000000000000007346545000016362 5ustar0000000000000000generic-lens-2.2.2.0/src/Data/Generics/Sum/Any.hs0000644000000000000000000000463507346545000017455 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Any -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Derive a variety of prisms generically. -- ----------------------------------------------------------------------------- module Data.Generics.Sum.Any ( -- *Prisms -- -- $setup AsAny (..) ) where import "this" Data.Generics.Internal.VL.Prism import "this" Data.Generics.Sum.Constructors import "this" Data.Generics.Sum.Typed -- $setup -- == /Running example:/ -- -- >>> :set -XTypeApplications -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics -- >>> import Control.Lens -- >>> :{ -- data Animal -- = Dog Dog -- | Cat Name Age -- | Duck Age -- deriving (Generic, Show) -- data Dog -- = MkDog -- { name :: Name -- , age :: Age -- } -- deriving (Generic, Show) -- type Name = String -- type Age = Int -- dog, cat, duck :: Animal -- dog = Dog (MkDog "Shep" 3) -- cat = Cat "Mog" 5 -- duck = Duck 2 -- :} -- |Sums that have generic prisms. class AsAny sel a s | s sel -> a where -- |A prism that projects a sum as identified by some selector. Currently -- supported selectors are constructor names and unique types. Compatible -- with the lens package's 'Control.Lens.Prism' type. -- -- >>> dog ^? _As @"Dog" -- Just (MkDog {name = "Shep", age = 3}) -- -- >>> dog ^? _As @Dog -- Just (MkDog {name = "Shep", age = 3}) -- -- >>> dog ^? _As @"Cat" -- Nothing -- -- >>> cat ^? _As @(Name, Age) -- Just ("Mog",5) -- -- >>> cat ^? _As @"Cat" -- Just ("Mog",5) -- -- >>> _As @"Cat" # ("Garfield", 6) :: Animal -- Cat "Garfield" 6 -- -- >>> duck ^? _As @Age -- Just 2 _As :: Prism s s a a instance AsConstructor ctor s s a a => AsAny ctor a s where _As = _Ctor @ctor instance AsType a s => AsAny a a s where _As = _Typed @a generic-lens-2.2.2.0/src/Data/Generics/Sum/Constructors.hs0000644000000000000000000001057107346545000021432 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Constructors -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Derive constructor-name-based prisms generically. -- ----------------------------------------------------------------------------- module Data.Generics.Sum.Constructors ( -- *Prisms -- $setup AsConstructor (..) , AsConstructor_ (..) , AsConstructor' (..) , AsConstructor0 (..) ) where import "this" Data.Generics.Internal.VL.Prism import "generic-lens-core" Data.Generics.Internal.Void import qualified "generic-lens-core" Data.Generics.Sum.Internal.Constructors as Core import GHC.TypeLits (Symbol) -- $setup -- == /Running example:/ -- -- >>> :set -XTypeApplications -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> :set -XFlexibleContexts -- >>> :set -XTypeFamilies -- >>> import GHC.Generics -- >>> import Control.Lens -- >>> :m +Data.Generics.Product.Fields -- >>> :m +Data.Function -- >>> :{ -- data Animal a -- = Dog (Dog a) -- | Cat Name Age -- | Duck Age -- deriving (Generic, Show) -- data Dog a -- = MkDog -- { name :: Name -- , age :: Age -- , fieldA :: a -- } -- deriving Show -- type Name = String -- type Age = Int -- dog, cat, duck :: Animal Int -- dog = Dog (MkDog "Shep" 3 30) -- cat = Cat "Mog" 5 -- duck = Duck 2 -- :} -- |Sums that have a constructor with a given name. class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where -- |A prism that projects a named constructor from a sum. Compatible with the -- lens package's 'Control.Lens.Prism' type. -- -- >>> dog ^? _Ctor @"Dog" -- Just (MkDog {name = "Shep", age = 3, fieldA = 30}) -- -- >>> dog ^? _Ctor @"Cat" -- Nothing -- -- >>> cat ^? _Ctor @"Cat" -- Just ("Mog",5) -- -- >>> _Ctor @"Cat" # ("Garfield", 6) :: Animal Int -- Cat "Garfield" 6 -- -- === /Type errors/ -- -- >>> cat ^? _Ctor @"Turtle" -- ... -- ... -- ... The type Animal Int does not contain a constructor named "Turtle" -- ... _Ctor :: Prism s t a b -- |Sums that have a constructor with a given name. -- -- The difference between 'HasConstructor' and 'HasConstructor_' is similar to -- the one between 'Data.Generics.Product.Fields.HasField' and -- 'Data.Generics.Product.Fields.HasField_'. -- See 'Data.Generics.Product.Fields.HasField_'. class AsConstructor_ (ctor :: Symbol) s t a b where _Ctor_ :: Prism s t a b class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where _Ctor' :: Prism s s a a -- |Sums that have a constructor with a given name. -- -- This class gives the minimal constraints needed to define this prism. -- For common uses, see 'HasConstructor'. class AsConstructor0 (ctor :: Symbol) s t a b where _Ctor0 :: Prism s t a b instance (Core.Context' ctor s a, AsConstructor0 ctor s s a a) => AsConstructor' ctor s a where _Ctor' eta = _Ctor0 @ctor eta {-# INLINE _Ctor' #-} instance (Core.Context ctor s t a b, AsConstructor0 ctor s t a b) => AsConstructor ctor s t a b where _Ctor eta = _Ctor0 @ctor eta {-# INLINE _Ctor #-} -- | Uncluttering type signatures (see 'Void') -- -- >>> :t +d _Ctor -- _Ctor -- :: (AsConstructor ctor s t a b, Choice p, Applicative f) => -- p a (f b) -> p s (f t) instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where _Ctor = undefined instance (Core.Context_ ctor s t a b, AsConstructor0 ctor s t a b) => AsConstructor_ ctor s t a b where _Ctor_ = _Ctor0 @ctor {-# INLINE _Ctor_ #-} instance {-# OVERLAPPING #-} AsConstructor_ ctor (Void1 a) (Void1 b) a b where _Ctor_ = undefined instance Core.Context0 ctor s t a b => AsConstructor0 ctor s t a b where _Ctor0 eta = prism2prismvl (Core.derived0 @ctor) eta {-# INLINE _Ctor0 #-} generic-lens-2.2.2.0/src/Data/Generics/Sum/Subtype.hs0000644000000000000000000000763007346545000020357 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Subtype -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Structural subtype relationships between sum types. -- ----------------------------------------------------------------------------- module Data.Generics.Sum.Subtype ( -- *Prisms -- -- $setup AsSubtype (..) ) where import "this" Data.Generics.Internal.VL.Prism import "generic-lens-core" Data.Generics.Internal.Void import qualified "generic-lens-core" Data.Generics.Sum.Internal.Subtype as Core -- $setup -- == /Running example:/ -- -- >>> :set -XTypeApplications -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics -- >>> import Control.Lens -- >>> :{ -- data Animal -- = Dog Dog -- | Cat Name Age -- | Duck Age -- deriving (Generic, Show) -- data FourLeggedAnimal -- = Dog4 Dog -- | Cat4 Name Age -- deriving (Generic, Show) -- data Dog = MkDog -- { name :: Name -- , age :: Age -- } -- deriving (Generic, Show) -- type Name = String -- type Age = Int -- dog, cat, duck :: Animal -- dog = Dog (MkDog "Shep" 3) -- cat = Cat "Mog" 5 -- duck = Duck 2 -- dog4, cat4 :: FourLeggedAnimal -- dog4 = Dog4 (MkDog "Snowy" 4) -- cat4 = Cat4 "Garfield" 6 -- :} -- |Structural subtyping between sums. A sum 'Sub' is a subtype of another sum -- 'Sup' if a value of 'Sub' can be given (modulo naming of constructors) -- whenever a value of 'Sup' is expected. In the running example for instance, -- 'FourLeggedAnimal` is a subtype of 'Animal' since a value of the former can -- be given as a value of the latter (renaming 'Dog4' to 'Dog' and 'Cat4' to -- 'Cat'). class AsSubtype sub sup where -- |A prism that captures structural subtyping. Allows a substructure to be -- injected (upcast) into a superstructure or a superstructure to be downcast -- into a substructure (which may fail). -- -- >>> _Sub # dog4 :: Animal -- Dog (MkDog {name = "Snowy", age = 4}) -- -- >>> cat ^? _Sub :: Maybe FourLeggedAnimal -- Just (Cat4 "Mog" 5) -- -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal -- Nothing _Sub :: Prism' sup sub _Sub = prism injectSub (\i -> maybe (Left i) Right (projectSub i)) {-# INLINE _Sub #-} -- |Injects a subtype into a supertype (upcast). injectSub :: sub -> sup injectSub = build (_Sub @sub @sup) -- |Projects a subtype from a supertype (downcast). projectSub :: sup -> Maybe sub projectSub = either (const Nothing) Just . match (_Sub @sub @sup) {-# MINIMAL (injectSub, projectSub) | _Sub #-} instance Core.Context sub sup => AsSubtype sub sup where _Sub f = prism2prismvl Core.derived f {-# INLINE _Sub #-} -- | Reflexive case -- -- >>> _Sub # dog :: Animal -- Dog (MkDog {name = "Shep", age = 3}) instance {-# OVERLAPPING #-} AsSubtype a a where _Sub = id {-# INLINE _Sub #-} -- | Uncluttering type signatures (see 'Void') -- -- >>> :t +d _Sub -- _Sub -- :: (AsSubtype sub sup, Choice p, Applicative f) => -- p sub (f sub) -> p sup (f sup) instance {-# OVERLAPPING #-} AsSubtype a Void where injectSub = undefined projectSub = undefined -- | Uncluttering type signatures (see 'Void') -- -- >>> :t +d _Sub @Int -- _Sub @Int -- :: (AsSubtype Int sup, Choice p, Applicative f) => -- p Int (f Int) -> p sup (f sup) instance {-# OVERLAPPING #-} AsSubtype Void a where injectSub = undefined projectSub = undefined generic-lens-2.2.2.0/src/Data/Generics/Sum/Typed.hs0000644000000000000000000000661107346545000020007 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Typed -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Derive constructor-field-type-based prisms generically. -- ----------------------------------------------------------------------------- module Data.Generics.Sum.Typed ( -- *Prisms -- -- $setup AsType (..) ) where import "this" Data.Generics.Internal.VL.Prism import qualified "generic-lens-core" Data.Generics.Sum.Internal.Typed as Core import "generic-lens-core" Data.Generics.Internal.Void -- $setup -- >>> :set -XTypeApplications -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics -- >>> import Control.Lens -- >>> :{ -- data Animal -- = Dog Dog -- | Cat Name Age -- | Duck Age -- | Turtle Age -- deriving (Generic, Show) -- data Dog -- = MkDog -- { name :: Name -- , age :: Age -- } -- deriving (Generic, Show) -- type Name = String -- newtype Age = Age Int deriving Show -- dog, cat, duck :: Animal -- dog = Dog (MkDog "Shep" (Age 3)) -- cat = Cat "Mog" (Age 5) -- duck = Duck (Age 2) -- :} -- |Sums that have a constructor with a field of the given type. class AsType a s where -- |A prism that projects a constructor uniquely identifiable by the type of -- its field. Compatible with the lens package's 'Control.Lens.Prism' type. -- -- >>> dog ^? _Typed @Dog -- Just (MkDog {name = "Shep", age = Age 3}) -- >>> cat ^? _Typed @(Name, Age) -- Just ("Mog",Age 5) -- >>> dog ^? _Typed @Age -- ... -- ... -- ... The type Animal contains multiple constructors whose fields are of type Age. -- ... The choice of constructor is thus ambiguous, could be any of: -- ... Duck -- ... Turtle -- ... _Typed :: Prism' s a _Typed = prism injectTyped (\i -> maybe (Left i) Right (projectTyped i)) {-# INLINE _Typed #-} -- |Inject by type. injectTyped :: a -> s injectTyped = build _Typed -- |Project by type. projectTyped :: s -> Maybe a projectTyped = either (const Nothing) Just . match _Typed {-# MINIMAL (injectTyped, projectTyped) | _Typed #-} instance Core.Context a s => AsType a s where _Typed eta = prism2prismvl Core.derived eta {-# INLINE _Typed #-} -- | Uncluttering type signatures (see 'Void') -- -- >>> :t +d _Typed -- _Typed -- :: (AsType a s, Choice p, Applicative f) => p a (f a) -> p s (f s) instance {-# OVERLAPPING #-} AsType a Void where _Typed = undefined injectTyped = undefined projectTyped = undefined -- | Uncluttering type signatures (see 'Void') -- -- >>> :t +d _Typed @Int -- _Typed @Int -- :: (AsType Int s, Choice p, Applicative f) => -- p Int (f Int) -> p s (f s) instance {-# OVERLAPPING #-} AsType Void a where _Typed = undefined injectTyped = undefined projectTyped = undefined generic-lens-2.2.2.0/src/Data/Generics/Wrapped.hs0000644000000000000000000000403207346545000017553 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} {-# language ConstraintKinds #-} {-# language DataKinds #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language FunctionalDependencies #-} {-# language MultiParamTypeClasses #-} {-# language ScopedTypeVariables #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Wrapped -- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- -- Derive an isomorphism between a newtype and its wrapped type. -- ----------------------------------------------------------------------------- module Data.Generics.Wrapped ( Wrapped (..) , wrappedTo , wrappedFrom , _Unwrapped , _Wrapped ) where import qualified "this" Data.Generics.Internal.VL.Iso as VL import "generic-lens-core" Data.Generics.Internal.Wrapped (Context, derived) import Control.Applicative (Const(..)) -- | @since 1.1.0.0 _Unwrapped :: Wrapped s t a b => VL.Iso s t a b _Unwrapped = wrappedIso {-# inline _Unwrapped #-} -- | @since 1.1.0.0 _Wrapped :: Wrapped s t a b => VL.Iso b a t s _Wrapped = VL.fromIso wrappedIso {-# inline _Wrapped #-} -- | @since 1.1.0.0 class Wrapped s t a b | s -> a, t -> b where -- | @since 1.1.0.0 wrappedIso :: VL.Iso s t a b -- | @since 1.1.0.0 wrappedTo :: forall s t a b. Wrapped s t a b => s -> a wrappedTo a = view (wrappedIso @s @t @a @b) a where view l s = getConst (l Const s) {-# INLINE wrappedTo #-} -- | @since 1.1.0.0 wrappedFrom :: forall s t a b. Wrapped s t a b => b -> t wrappedFrom a = view (VL.fromIso (wrappedIso @s @t @a @b)) a where view l s = getConst (l Const s) {-# INLINE wrappedFrom #-} instance Context s t a b => Wrapped s t a b where wrappedIso = VL.iso2isovl derived {-# INLINE wrappedIso #-} generic-lens-2.2.2.0/test/0000755000000000000000000000000007346545000013376 5ustar0000000000000000generic-lens-2.2.2.0/test/Bifunctor.hs0000644000000000000000000000250507346545000015667 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} module Main (main) where import Control.Lens hiding (Bifunctor(..)) import Control.Monad (void) import Data.Generics.Product import GHC.Generics import Test.HUnit main :: IO () main = void $ runTestTT $ bimap (* 2) show mytree ~=? mytreeBimapped data Tree a w = Leaf a | Fork (Tree a w) (Tree a w) | WithWeight (Tree a w) w deriving (Show, Eq, Generic) instance Bifunctor Tree where bimap = gbimap mytree :: Tree Int Int mytree = Fork (WithWeight (Leaf 42) 1) (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) mytreeBimapped :: Tree Int String mytreeBimapped = Fork (WithWeight (Leaf 84) "1") (WithWeight (Fork (Leaf 176) (Leaf 74)) "2") -------------------------------------------------------------------------------- class Bifunctor p where bimap :: (a -> c) -> (b -> d) -> p a b -> p c d gbimap :: ( HasParam 0 (p a b) (p a d) b d , HasParam 1 (p a d) (p c d) a c ) => (a -> c) -> (b -> d) -> p a b -> p c d gbimap f g s = s & param @0 %~ g & param @1 %~ f generic-lens-2.2.2.0/test/CustomChildren.hs0000644000000000000000000000401007346545000016650 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module CustomChildren ( customTypesTest ) where import GHC.Generics import Data.Generics.Product import Test.HUnit import Data.Generics.Internal.VL.Lens import Data.Generics.Labels () import Data.Kind -- Opaque has no Generic instance data Opaque = Opaque String deriving (Show, Eq) -- Hide does have a Generic instance, but we want to hide its contents -- from the traversal data Hide = Hide String deriving (Show, Generic, Eq) -- We first define a symbol for the custom traversal data Custom type instance Children Custom a = ChildrenCustom a type family ChildrenCustom (a :: Type) where ChildrenCustom Opaque = '[String] -- here we state explicitly that Opaque contains a String ChildrenCustom Hide = '[] -- and hide the contents of Hide ChildrenCustom a = Children ChGeneric a -- for the rest, we defer to the generic children -- We define the traversal of Opaque like so: instance HasTypesCustom Custom Opaque Opaque String String where typesCustom f (Opaque str) = Opaque <$> f str customTypesTest1 :: Test customTypesTest1 = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected) where original = (Opaque "foo", Hide "bar") expected = (Opaque "foo!", Hide "bar") -- only Opaque's String gets modified customTypesTest2 :: Test customTypesTest2 = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected) where original = Opaque "foo" expected = Opaque "foo!" customTypesTest3 :: Test customTypesTest3 = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected) where original = Hide "foo" expected = Hide "foo" customTypesTest :: Test customTypesTest = TestList [customTypesTest1, customTypesTest2, customTypesTest3] generic-lens-2.2.2.0/test/Spec.hs0000644000000000000000000002173607346545000014635 0ustar0000000000000000{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-} {-# OPTIONS_GHC -dsuppress-all #-} {-# OPTIONS_GHC -funfolding-use-threshold=150 #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedLabels #-} module Main where import GHC.Generics import Data.Generics.Product import Data.Generics.Sum import Test.Inspection import Test.HUnit import Util import System.Exit import Data.Generics.Internal.VL import Control.Lens (_1, (+~), (^?)) import Data.Function ((&)) import Data.Generics.Labels () -- This is sufficient at we only want to test that they typecheck import Test24 () import Test25 () import Test88 () import CustomChildren (customTypesTest) main :: IO () main = do res <- runTestTT tests case errors res + failures res of 0 -> exitSuccess _ -> exitFailure data Record = MkRecord { fieldA :: Int , fieldB :: Bool } deriving Generic data Record2 = MkRecord2 { fieldA :: Int } deriving Generic data Record3 a = MkRecord3 { fieldA :: a , fieldB :: Bool } deriving (Generic, Show) data Record4 a = MkRecord4 { fieldA :: a , fieldB :: a } deriving (Generic1) data Record5 = MkRecord5 { fieldA :: Int , fieldB :: Int , fieldC :: String , fieldD :: Int , fieldE :: Char , fieldF :: Int } deriving Generic typeChangingManual :: Lens (Record3 a) (Record3 b) a b typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a typeChangingManualCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b typeChangingManualCompose = typeChangingManual . typeChangingManual newtype L s a = L (Lens' s a) intTraversalManual :: Traversal' Record5 Int intTraversalManual f (MkRecord5 a b c d e f') = pure (\a1 a2 a3 a4 -> MkRecord5 a1 a2 c a3 e a4) <*> f a <*> f b <*> f d <*> f f' intTraversalDerived :: Traversal' Record5 Int intTraversalDerived = types fieldALensManual :: Lens' Record Int fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a subtypeLensManual :: Lens' Record Record2 subtypeLensManual f record = fmap (\ds -> case record of MkRecord _ b -> MkRecord (case ds of {MkRecord2 g1 -> g1}) b ) (f (MkRecord2 (case record of {MkRecord a _ -> a}))) data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show) data Sum2 = A2 Char | B2 Int deriving (Generic, Show) data Sum3 a b c = A3 a a | B3 String b a a b | C3 c a Int deriving Generic sum3Param0Derived :: Traversal (Sum3 a b xxx) (Sum3 a b yyy) xxx yyy sum3Param0Derived = param @0 sum3Param0Manual :: Traversal (Sum3 a b xxx) (Sum3 a b yyy) xxx yyy sum3Param0Manual _ (A3 a1 a2) = pure (A3 a1 a2) sum3Param0Manual _ (B3 s b1 a1 a2 b2) = pure (B3 s b1 a1 a2 b2) sum3Param0Manual f (C3 c a i) = pure (\c' -> C3 c' a i) <*> f c sum3Param1Derived :: Traversal (Sum3 a xxx c) (Sum3 a yyy c) xxx yyy sum3Param1Derived = param @1 sum3Param1Manual :: Traversal (Sum3 a xxx c) (Sum3 a yyy c) xxx yyy sum3Param1Manual _ (A3 a1 a2) = pure (A3 a1 a2) sum3Param1Manual f (B3 s b1 a1 a2 b2) = pure (\b1' b2' -> B3 s b1' a1 a2 b2') <*> f b1 <*> f b2 sum3Param1Manual _ (C3 c a i) = pure (C3 c a i) sum3Param2Derived :: Traversal (Sum3 xxx b c) (Sum3 yyy b c) xxx yyy sum3Param2Derived = param @2 sum3Param2Manual :: Traversal (Sum3 xxx b c) (Sum3 yyy b c) xxx yyy sum3Param2Manual f (A3 a1 a2) = pure (\a1' a2' -> A3 a1' a2') <*> f a1 <*> f a2 sum3Param2Manual f (B3 s b1 a1 a2 b2) = pure (\a1' a2' -> B3 s b1 a1' a2' b2) <*> f a1 <*> f a2 sum3Param2Manual f (C3 c a i) = pure (\a' -> C3 c a' i) <*> f a sum1PrismManual :: Prism Sum1 Sum1 Int Int sum1PrismManual eta = prism g f eta where f s1 = case s1 of B i -> Right i s -> Left s g = B sum1PrismManualChar :: Prism Sum1 Sum1 Char Char sum1PrismManualChar eta = prism g f eta where f s1 = case s1 of A i -> Right i B _ -> Left s1 C _ -> Left s1 D _ -> Left s1 g = A sum2PrismManual :: Prism Sum2 Sum2 Int Int sum2PrismManual eta = prism g f eta where f s1 = case s1 of B2 i -> Right i s -> Left s g = B2 sum2PrismManualChar :: Prism Sum2 Sum2 Char Char sum2PrismManualChar eta = prism g f eta where f s1 = case s1 of A2 i -> Right i s -> Left s g = A2 -- Note we don't have a catch-all case because of #14684 subtypePrismManual :: Prism Sum1 Sum1 Sum2 Sum2 subtypePrismManual eta = prism g f eta where f s1 = case s1 of A c -> Right (A2 c) B i -> Right (B2 i) C _ -> Left s1 D _ -> Left s1 g (A2 c) = A c g (B2 i) = B i -------------------------------------------------------------------------------- -- * Tests -- The inspection-testing plugin checks that the following equalities hold, by -- checking that the LHSs and the RHSs are CSEd. This also means that the -- runtime characteristics of the derived lenses is the same as the manually -- written ones above. fieldALensName :: Lens' Record Int fieldALensName = field @"fieldA" fieldALensName_ :: Lens' Record Int fieldALensName_ = field_ @"fieldA" fieldALensType :: Lens' Record Int fieldALensType = typed @Int fieldALensPos :: Lens' Record Int fieldALensPos = position @1 fieldALensPos_ :: Lens' Record Int fieldALensPos_ = position_ @1 subtypeLensGeneric :: Lens' Record Record2 subtypeLensGeneric = super typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b typeChangingGeneric = #fieldA typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b typeChangingGenericPos = position @1 typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b typeChangingGenericCompose = #fieldA . #fieldA typeChangingGenericCompose_ :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b typeChangingGenericCompose_ = field_ @"fieldA" . field_ @"fieldA" sum1PrismB :: Prism Sum1 Sum1 Int Int sum1PrismB = _Ctor @"B" subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2 subtypePrismGeneric = _Sub sum1TypePrism :: Prism Sum1 Sum1 Int Int sum1TypePrism = _Typed @Int sum1TypePrismChar :: Prism Sum1 Sum1 Char Char sum1TypePrismChar = _Typed @Char sum2TypePrism :: Prism Sum2 Sum2 Int Int sum2TypePrism = _Typed @Int sum2TypePrismChar :: Prism Sum2 Sum2 Char Char sum2TypePrismChar = _Typed @Char data SumOfProducts = RecA { _foo :: Int, valA :: String } | RecB { _foo :: Int, valB :: Bool } | RecC { _foo :: Int } deriving (Show, Eq, Generic) tests :: Test tests = TestList $ map mkHUnitTest [ $(inspectTest $ 'fieldALensManual === 'fieldALensName) , $(inspectTest $ 'fieldALensManual === 'fieldALensName_) , $(inspectTest $ 'fieldALensManual === 'fieldALensType) , $(inspectTest $ 'fieldALensManual === 'fieldALensPos) , $(inspectTest $ 'fieldALensManual === 'fieldALensPos_) -- , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric) -- TODO fails >=9.2 , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric) , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos) , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose) , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose_) , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB) -- , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric) (TODO: fails on 8.4) , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar) , $(inspectTest $ 'sum2PrismManual === 'sum2TypePrism) , $(inspectTest $ 'sum1PrismManualChar === 'sum1TypePrismChar) , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar) , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism) , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived) -- , $(inspectTest $ 'sum3Param0Manual === 'sum3Param0Derived) -- TODO fails >=9.0 -- , $(inspectTest $ 'sum3Param1Manual === 'sum3Param1Derived) -- TODO fails >=9.0 -- , $(inspectTest $ 'sum3Param2Manual === 'sum3Param2Derived) -- TODO fails >=9.0 ] ++ -- Tests for overloaded labels [ (valLabel ^. #_foo ) ~=? 3 , (valLabel & #_foo +~ 10 ) ~=? RecB 13 True , (valLabel ^? #_RecB . _1 ) ~=? Just 3 , (valLabel ^? #_RecB ) ~=? Just (3, True) , (valLabel ^? #_RecC ) ~=? Nothing #if MIN_VERSION_base(4,18,0) , (valLabel ^? #RecB . _1 ) ~=? Just 3 , (valLabel ^? #RecB ) ~=? Just (3, True) , (valLabel ^? #RecC ) ~=? Nothing #endif , customTypesTest ] where valLabel = RecB 3 True -- TODO: add test for traversals over multiple types generic-lens-2.2.2.0/test/Test24.hs0000644000000000000000000000322207346545000015016 0ustar0000000000000000{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-} module Test24 where -- Test case from #24, comments preserved import Control.Lens import Data.Generics.Product.Fields import Data.Generics.Product.Positions import GHC.Generics data Foo a b = Foo { x1 :: a, x2 :: b } deriving (Generic, Show) data Bar a b = Bar { x3 :: Foo a b, x4 :: Int } deriving (Generic, Show) tup :: ((Int, Char), Int) tup = ((1, 'a'), 2) tup2, tup3, tup4 :: ((Char, Char), Int) tup2 = tup & _1 . _1 %~ toEnum -- Works. tup3 = tup & x %~ toEnum -- Works also with type annotation. where x :: Lens ((Int, Char), Int) ((Char, Char), Int) Int Char x = _1 . _1 -- Works. tup4 = tup & position @1 . position @1 %~ toEnum foo :: Foo Int Char foo = Foo 1 'a' foo2, foo3 :: Foo Char Char foo2 = foo & field @"x1" %~ toEnum -- Works when there's just one 'field'. foo3 = foo & position @1 %~ toEnum -- Works when there's just one 'position'. bar :: Bar Int Char bar = Bar (Foo 1 'a') 2 bar2, bar3, bar4 :: Bar Char Char -- Doesn't work, error at first 'field' (Couldn't match type ‘Int’ with ‘Char’ arising from a use of ‘field’). bar2 = bar & field @"x3" . field @"x1" %~ toEnum -- Type annotation doesn't help. bar3 = bar & l %~ toEnum where l :: Lens (Bar Int Char) (Bar Char Char) Int Char l = field @"x3" . field @"x1" -- Doesn't work, error at first 'position' (Couldn't match type ‘Int’ with ‘Char’ arising from a use of ‘position’). bar4 = bar & position @1 . position @1 %~ toEnum -- Works if we stick to simple Lens' (modify to the same type). bar5 :: Bar Int Char bar5 = bar & field @"x3" . field @"x1" %~ (+1) main :: IO () main = print bar5 generic-lens-2.2.2.0/test/Test25.hs0000644000000000000000000000134007346545000015016 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_GHC -Wall #-} module Test25 where import Control.Lens import Data.Generics.Product import GHC.Generics data Record1 = Record1 { field1 :: Int , field2 :: Double } deriving (Generic) class Default a where def :: a instance Default Record1 where def = Record1 0 0.0 f :: Record1 -> Int f r = r ^. field @"field1" main :: IO () main = do print $ f def print $ f ( field @"field1" .~ 1 $ (def :: Record1)) print $ f ( field @"field1" .~ 2 $ Record1 0 0.0) print $ f ( field @"field1" .~ (1 :: Int) $ def) print $ f ( position @1 .~ (1 :: Int) $ def) generic-lens-2.2.2.0/test/Test40.hs0000644000000000000000000000065007346545000015016 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_GHC -Wall #-} module Test40 where import Data.Generics.Product import GHC.Generics class MyClass a where data AssocData a instance MyClass Int where data AssocData Int = SomeData { val :: Int } deriving (Generic) main :: IO () main = print $ getField @"val" (SomeData 3) generic-lens-2.2.2.0/test/Test62.hs0000644000000000000000000000117707346545000015027 0ustar0000000000000000{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-} module Test62 (example, example_) where import Data.Generics.Product (field, field_, position, position_) import Data.Generics.Internal.VL.Lens (set) import GHC.Generics (Generic) data Foo a = Foo { bar :: Bar a } deriving Generic data Bar a = Bar { x :: a, y :: a } deriving Generic example :: Foo () example = set (field @"bar" . position @1) () . set (position @1 . field @"y") () $ Foo{ bar = Bar{ x = (), y = () } } example_ :: Foo () example_ = set (field_ @"bar" . position_ @1) () . set (position_ @1 . field_ @"y") () $ Foo{ bar = Bar{ x = (), y = () } } generic-lens-2.2.2.0/test/Test63.hs0000644000000000000000000000057207346545000015026 0ustar0000000000000000{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-} module Test63 (example) where import Data.Generics.Product (types) import Data.Generics.Internal.VL.Lens (over) import Data.Word (Word32) import GHC.Generics (Generic) data Record = Record {field1 :: Word32, field2 :: Int} deriving (Generic, Show) example :: Record example = over (types @Int) (+1) (Record 0 0) generic-lens-2.2.2.0/test/Test88.hs0000644000000000000000000000064507346545000015036 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} -- | module Test88 where import Control.Lens import Data.Generics.Product.Param import GHC.Generics data Foo a = Foo a deriving (Eq, Show, Generic) data Bar b = Bar b deriving (Eq, Show, Generic) data FooBar c = FooBar (Foo (Bar c)) deriving (Eq, Show, Generic) foo :: FooBar Int -> FooBar String foo = over (param @0) show generic-lens-2.2.2.0/test/Util.hs0000644000000000000000000000030507346545000014645 0ustar0000000000000000module Util where import Test.Inspection import Test.HUnit.Base mkHUnitTest :: Result -> Test mkHUnitTest r = TestCase $ case r of Success _s -> return () Failure s -> assertFailure s generic-lens-2.2.2.0/test/syb/0000755000000000000000000000000007346545000014173 5ustar0000000000000000generic-lens-2.2.2.0/test/syb/Tree.hs0000644000000000000000000000461507346545000015434 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {- Example adapted from SYB ======================== -} module Main (main) where import Control.Lens import Control.Monad (void) import Data.Generics.Product import GHC.Generics import Test.HUnit main :: IO () main = void $ runTestTT tests -- A parameterised datatype for binary trees with data at the leafs data Tree a w = Leaf a | Fork (Tree a w) (Tree a w) | WithWeight (Tree a w) w deriving (Show, Generic, Eq) -- A typical tree mytree :: Tree Int Int mytree = Fork (WithWeight (Leaf 42) 1) (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) mytreeShown :: Tree String Int mytreeShown = Fork (WithWeight (Leaf "42") 1) (WithWeight (Fork (Leaf "88") (Leaf "37")) 2) -- A polymorphic-recursive structure data Poly a b = PNil | PCons a (Poly b a) deriving (Show, Generic) poly :: Poly Int String poly = PCons 10 (PCons "hello" (PCons 20 (PCons "world" PNil))) -- Print everything like an Int in mytree -- In fact, we show two attempts: -- 1. print really just everything like an Int -- 2. print everything wrapped with Leaf -- So (1.) confuses leafs and weights whereas (2.) does not. tests :: Test tests = TestList [ toListOf (types @Int) mytree ~=? [42,1,88,37,2] , toListOf (param @1) mytree ~=? [42,88,37] -- Things not (easily) doable in SYB: -- change type of Tree by mapping a function over the second (from the right) param , (mytree & param @1 %~ show) ~=? mytreeShown -- collect values in poly corresponding to the first param , toListOf (param @0) poly ~=? ["hello", "world"] -- collect all Ints inside poly , toListOf (types @Int) poly ~=? [10, 20] -- map length over the Strings, then collect all Ints , toListOf (types @Int) (poly & param @0 %~ length) ~=? [10, 5, 20, 5] -- map length over the Strings, then collect all the resulting Ints , toListOf (param @0) (poly & param @0 %~ length) ~=? [5,5] ] -- original code from SYB: --tests = show ( listify (\(_::Int) -> True) mytree -- , everything (++) ([] `mkQ` fromLeaf) mytree -- ) ~=? output -- where -- fromLeaf :: Tree Int Int -> [Int] -- fromLeaf (Leaf x) = [x] -- fromLeaf _ = []