generic-lens 0.5.1.0 → 2.3.0.0
raw patch · 56 files changed
Files
- ChangeLog.md +73/−4
- LICENSE +1/−1
- README.md +0/−258
- benchmarks/Bench.hs +0/−64
- examples/Examples.hs +11/−7
- examples/doctest.hs +6/−0
- generic-lens.cabal +58/−61
- src/Data/Generics/Internal/Families.hs +0/−35
- src/Data/Generics/Internal/Families/Changing.hs +0/−145
- src/Data/Generics/Internal/Families/Collect.hs +0/−132
- src/Data/Generics/Internal/Families/Has.hs +0/−97
- src/Data/Generics/Internal/HList.hs +0/−239
- src/Data/Generics/Internal/Lens.hs +0/−143
- src/Data/Generics/Internal/VL.hs +14/−0
- src/Data/Generics/Internal/VL/Iso.hs +93/−0
- src/Data/Generics/Internal/VL/Lens.hs +72/−0
- src/Data/Generics/Internal/VL/Prism.hs +85/−0
- src/Data/Generics/Internal/Void.hs +0/−18
- src/Data/Generics/Labels.hs +208/−0
- src/Data/Generics/Product.hs +14/−6
- src/Data/Generics/Product/Any.hs +8/−7
- src/Data/Generics/Product/Fields.hs +61/−58
- src/Data/Generics/Product/HList.hs +49/−0
- src/Data/Generics/Product/Internal/Fields.hs +0/−77
- src/Data/Generics/Product/Internal/Positions.hs +0/−90
- src/Data/Generics/Product/Internal/Subtype.hs +0/−92
- src/Data/Generics/Product/Internal/Typed.hs +0/−62
- src/Data/Generics/Product/Param.hs +51/−0
- src/Data/Generics/Product/Positions.hs +61/−49
- src/Data/Generics/Product/Subtype.hs +33/−38
- src/Data/Generics/Product/Typed.hs +35/−64
- src/Data/Generics/Product/Types.hs +112/−0
- src/Data/Generics/Sum.hs +6/−5
- src/Data/Generics/Sum/Any.hs +8/−7
- src/Data/Generics/Sum/Constructors.hs +55/−43
- src/Data/Generics/Sum/Internal/Constructors.hs +0/−68
- src/Data/Generics/Sum/Internal/Subtype.hs +0/−74
- src/Data/Generics/Sum/Internal/Typed.hs +0/−88
- src/Data/Generics/Sum/Subtype.hs +40/−17
- src/Data/Generics/Sum/Typed.hs +56/−45
- src/Data/Generics/Wrapped.hs +73/−0
- test/24.hs +0/−47
- test/25.hs +0/−33
- test/Bifunctor.hs +47/−0
- test/CustomChildren.hs +63/−0
- test/Spec.hs +212/−14
- test/Test146.hs +17/−0
- test/Test24.hs +47/−0
- test/Test25.hs +33/−0
- test/Test40.hs +22/−0
- test/Test62.hs +20/−0
- test/Test63.hs +12/−0
- test/Test88.hs +17/−0
- test/Util.hs +11/−0
- test/doctest.hs +0/−7
- test/syb/Tree.hs +76/−0
ChangeLog.md view
@@ -1,10 +1,79 @@-## 0.5.1.0+## generic-lens-2.3.0.0 (2025-08-27)++Tested with GHC 8.4 - 9.14 alpha1.++- Add `OverloadedLabels` support for positional lenses, e.g. `#3` as an+ abbreviation for `position @3`, starting with GHC 9.6.++### Breaking API changes:+- `AsType` now includes a reflexive case for consistency with `HasType`: every+ type can be treated 'as' itself.+++## 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 -## 0.5.0.0+## generic-lens-0.5.0.0 - Lenses and prisms are now type-changing. - More informative error messages@@ -16,7 +85,7 @@ - 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`
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2017, Csongor Kiss+Copyright (c) 2020, Csongor Kiss All rights reserved.
− README.md
@@ -1,258 +0,0 @@-# generic-lens--[](https://travis-ci.org/kcsongor/generic-lens)-[](https://hackage.haskell.org/package/generic-lens)--Generically derive lenses and prisms for data types.--Available on [Hackage](https://hackage.haskell.org/package/generic-lens)--This package uses the GHC 8 `Generic` representation to derive various operations-on data structures with lens interfaces, including structural subtype-relationships between records and positional indexing into arbitrary product-types.--This is made possible by GHC 8's new Generics API, which provides metadata-at the type-level (previously only value-level metadata was available).--Examples can be found in the `examples` folder. This library makes heavy use of-[Visible Type Applications](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication).--## Lenses--### Record fields--Record fields can be accessed by their label:--```haskell-data Person = Person { name :: String, age :: Int } deriving (Generic, Show)--sally :: Person-sally = Person "Sally" 25-```--```haskell->>> getField @"age" sally-25-->>> setField @"age" 26 sally-Person {name = "Sally", age = 26}-->>> sally ^. field @"name"-"Sally"-->>> sally & field @"name" .~ "Tamas"-Person {name = "Tamas", age = 25}-->>> sally ^. field @"pet"-error:- • The type Person does not contain a field named "pet"-```--If the accessed field is a type parameter that appears uniquely in the type,-then its type can be changed:--```haskell-data T a b c d = T- { paramA :: a- , paramB :: b- , paramC :: c- , paramD :: d- }- deriving (Generic, Show)-->>> t = T "a" (10 :: Int) 'c' False->>> t & field @"paramA" .~ 'a' & field @"paramB" .~ False-T {paramA = 'a', paramB = False, paramC = 'c', paramD = False}-```--### Positional fields--Fields can be accessed by their position in the data structure (index starting at 1):--```haskell-data Point = Point Int Int Int deriving (Generic, Show)-data Polygon = Polygon Point Point Point deriving (Generic, Show)--polygon :: Polygon-polygon = Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 7 (-2))-```--```haskell->>> getPosition @2 polygon-Point 2 4 2-->>> setPosition @1 (Point 26 5 3) polygon-Polygon (Point 26 5 3) (Point 2 4 2) (Point 5 7 (-2))-->>> polygon ^. position @1 . position @2-5-->>> polygon & position @3 . position @2 %~ (+10)-Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 17 (-2))-->>> polygon ^. position @10-error:- • The type Polygon does not contain a field at position 10-```--Since tuples are an instance of `Generic`, they also have positional lenses:--```haskell->>> (("hello", True), 5) ^. position @1 . position @2-True-```--### Typed fields--Fields can be accessed by their type in the data structure, assuming that this-type is unique:--```haskell-data Person = Person { name :: String, age :: Int } deriving (Generic, Show)-data Point = Point Int Int Int deriving (Generic, Show)--sally :: Person-sally = Person "Sally" 25--point :: Point-point = Point 1 2 3-```--```haskell->>> getTyped @String sally-"Sally"-->>> setTyped @Int sally 26-Person {name = "Sally", age = 26}-->>> point ^. typed @Int-error:- • The type Point contains multiple values of type Int; the choice of value is thus ambiguous-->>> point & typed @String .~ "Point"-error:- • The type Point does not contain a value of type [Char]-```--### Structural subtyping--A record is a (structural) `subtype' of another, if its fields are a superset of-those of the other.--```haskell-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 {name = "Tunyasz", age = 50, address = "London"}-```--```haskell-->>> upcast human :: Animal-Animal {name = "Tunyasz", age = 50}---- 'smash' plug the smaller structure into the larger one->>> smash (Animal "dog" 10) human-Human {name = "dog", age = 10, address = "London"}---- 'super' is a lens that focuses on a subrecord of a larger record:->>> human ^. super @Animal-Animal {name = "Tunyasz", age = 50}-```--We can apply a function that operates on a supertype to the larger (subtype)-structure, by focusing on the supertype first:--```haskell-growUp :: Animal -> Animal-growUp (Animal name age) = Animal name (age + 50)-->>> human & super @Animal %~ growUp-Human {name = "Tunyasz", age = 60, address = "London"}-```--## Prisms--### Named constructors--Constructor components can be accessed using the constructor's name:--```haskell-type Name = String-type Age = Int--data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)-data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show)--shep = Dog (MkDog "Shep" 4)-mog = Cat "Mog" 5-donald = Duck 4-```--```haskell->>> shep ^? _Ctor @"Dog"-Just (MkDog {name = "Shep", age = 4})-->>> shep ^? _Ctor @"Cat"-Nothing-->>> mog ^? _Ctor @"Cat"-Just ("Mog",5)-->>> _Ctor @"Cat" # ("Garfield", 6) :: Animal-Cat "Garfield" 6-->>> donald ^? _Ctor @"Giraffe"-error:- • The type Animal does not contain a constructor named "Giraffe"-```--### Typed constructors--Constructor components can be accessed using the component's type, assuming-that this type is unique:--```haskell-type Name = String-type Age = Int--data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)-data Animal = Dog Dog | Cat (Name, Age) | Duck Age deriving (Generic, Show)--shep = Dog (MkDog "Shep" 4)-mog = Cat ("Mog", 5)-donald = Duck 4-```--```haskell->>> mog ^? _Typed @Dog-Nothing-->>> shep ^? _Typed @Dog-Just (MkDog {name = "Shep", age = 4})-->>> donald ^? _Typed @Age-Just 4-->>> donald ^? _Typed @Float-error:- • The type Animal does not contain a constructor whose field is of type Float-->>> _Typed @Age # 6 :: Animal-Duck 6-```--## Contributors--+ [Toby Shaw](https://github.com/TobyShaw)-+ [Will Jones](https://github.com/lunaris)
− benchmarks/Bench.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeApplications #-}--module Main (main) where--import Control.DeepSeq-import Control.Lens.Operators-import Control.Lens.Type-import Control.Monad-import Criterion.Main-import Data.Generics.Product-import GHC.Generics-import Test.QuickCheck--main :: IO ()-main = defaultMain- [ env (arbitraryAnimalsOfLength 100) $ products 100- , env (arbitraryAnimalsOfLength 1000) $ products 1000- , env (arbitraryAnimalsOfLength 10000) $ products 10000- , env (arbitraryAnimalsOfLength 100000) $ products 100000- ]--products :: Int -> [Animal] -> Benchmark-products n as- = bgroup ("products/" ++ show n)- [ bench "generic-lens/get" (nf (const $ map (^. field @"name") as) ())- , bench "lens/get" (nf (const $ map (^. aName) as) ())- , bench "generic-lens/set" (nf (const $ map (\a -> a & field @"name" .~ "Name") as) ())- , bench "lens/set" (nf (const $ map (\a -> a & aName .~ "Name") as) ())- ]--arbitraryAnimalsOfLength :: Int -> IO [Animal]-arbitraryAnimalsOfLength n- = replicateM n (generate arbitrary)--data Animal = Animal- { name :: String- , age :: Int- , eats :: String- } deriving (Generic, Show)--instance Arbitrary Animal where- arbitrary = Animal <$> arbitrary <*> arbitrary <*> arbitrary--instance NFData Animal where- rnf Animal{..} = rnf name `seq` rnf age `seq` rnf eats--aName :: Lens' Animal String-aName f Animal{..}- = (\x -> Animal { name = x, age, eats }) <$> f name--{--aAge :: Lens' Animal Int-aAge f Animal{..}- = (\x -> Animal { name, age = x, eats }) <$> f age--aEats :: Lens' Animal String-aEats f Animal{..}- = (\x -> Animal { name, age, eats = x }) <$> f eats- -}
examples/Examples.hs view
@@ -17,11 +17,16 @@ module Examples where import Data.Function ((&))-import Data.Generics.Internal.Lens+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@@ -54,19 +59,16 @@ data Test a b = Test { fieldInt :: Int, fieldA :: a, fieldB :: b } deriving (Generic, Show) --- changedA :: Test Int String+-- | 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 String Int -- >>> changedB -- Test {fieldInt = 10, fieldA = "hello", fieldB = 10} changedB = (Test 10 "hello" "world") & field @"fieldB" .~ (10 :: Int) ---changedInt = set (field @"fieldInt") ("hello") (Test 10 "hello" "world")--- type error- data Animal2 a = Dog (Dog a) | Cat Name Age@@ -95,7 +97,9 @@ -- } -- deriving (Generic, Show) ---dog' :: Animal2 String+-- |+-- >>> :t dog'+-- dog' :: Animal2 [Char] dog' = dog & _Ctor @"Dog" . field @"fieldA" .~ "now it's a String" stuff ::
+ examples/doctest.hs view
@@ -0,0 +1,6 @@+import Test.DocTest+main+ = doctest+ [ "src"+ , "examples"+ ]
generic-lens.cabal view
@@ -1,7 +1,11 @@+cabal-version: 2.0 name: generic-lens-version: 0.5.1.0-synopsis: Generic data-structure operations exposed as lenses.-description: This package uses the GHC 8 Generic representation to derive various operations on data structures with a lens interface, including structural subtype relationship between records and positional indexing into arbitrary product types.+version: 2.3.0.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+ @<https://hackage.haskell.org/package/generic-optics generic-optics>@. homepage: https://github.com/kcsongor/generic-lens license: BSD3@@ -10,90 +14,98 @@ maintainer: kiss.csongor.kiss@gmail.com category: Generics, Records, Lens build-type: Simple-cabal-version: >= 1.10-Tested-With: GHC == 8.0.2, GHC == 8.2.1 -extra-source-files: ChangeLog.md- , examples/StarWars.hs+tested-with:+ GHC == 9.14.1+ GHC == 9.12.2+ GHC == 9.10.2+ GHC == 9.8.4+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+++extra-source-files: examples/StarWars.hs , examples/Examples.hs- , README.md +extra-doc-files: ChangeLog.md+ library- exposed-modules: Data.Generics.Product+ 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.Labels+ , 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.Lens - other-modules: Data.Generics.Internal.Families- , Data.Generics.Internal.Families.Changing- , Data.Generics.Internal.Families.Collect- , Data.Generics.Internal.Families.Has- , Data.Generics.Internal.HList- , Data.Generics.Internal.Void-- , Data.Generics.Sum.Internal.Constructors- , Data.Generics.Sum.Internal.Typed- , Data.Generics.Sum.Internal.Subtype-- , Data.Generics.Product.Internal.Fields- , Data.Generics.Product.Internal.Positions- , Data.Generics.Product.Internal.Subtype- , Data.Generics.Product.Internal.Typed+ , Data.Generics.Internal.VL+ , Data.Generics.Internal.VL.Lens+ , Data.Generics.Internal.VL.Prism+ , Data.Generics.Internal.VL.Iso - build-depends: base >= 4.9 && <= 5.0- , profunctors >= 5.0 && <= 6.0- , tagged >= 0.8 && <= 0.9+ build-depends: base >= 4.11 && < 5+ , generic-lens-core ^>= 2.3.0.0+ , profunctors hs-source-dirs: src default-language: Haskell2010+ default-extensions: TypeOperators ghc-options: -Wall -source-repository head- type: git- location: https://github.com/kcsongor/generic-lens--test-suite generic-lens-test+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 Test146 CustomChildren - build-depends: base >= 4.9 && <= 5.0+ build-depends: base , generic-lens- , inspection-testing >= 0.1+ , lens+ , mtl+ , inspection-testing >= 0.2+ , HUnit default-language: Haskell2010 ghc-options: -Wall -test-suite generic-lens-test-25+test-suite generic-lens-bifunctor type: exitcode-stdio-1.0 hs-source-dirs: test- main-is: 25.hs+ main-is: Bifunctor.hs - build-depends: base >= 4.9 && <= 5.0+ build-depends: base , generic-lens , lens+ , HUnit default-language: Haskell2010 ghc-options: -Wall -test-suite generic-lens-test-24+test-suite generic-lens-syb-tree type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: 24.hs+ hs-source-dirs: test/syb+ main-is: Tree.hs - build-depends: base >= 4.9 && <= 5.0+ build-depends: base , generic-lens , lens+ , HUnit default-language: Haskell2010 ghc-options: -Wall@@ -103,21 +115,6 @@ type: exitcode-stdio-1.0 ghc-options: -threaded main-is: doctest.hs- build-depends: base >4 && <5, doctest- hs-source-dirs: test--benchmark generic-lens-bench- type: exitcode-stdio-1.0- hs-source-dirs: benchmarks- main-is: Bench.hs-- build-depends: generic-lens-- , base >= 4.9 && <= 5.0- , QuickCheck- , criterion- , deepseq- , lens-- default-language: Haskell2010- ghc-options: -Wall+ build-depends: base >= 4 && <5+ , doctest+ hs-source-dirs: examples
− src/Data/Generics/Internal/Families.hs
@@ -1,35 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Module : Data.Generics.Internal.Families--- Copyright : (C) 2017 Csongor Kiss--- License : BSD3--- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability : experimental--- Portability : non-portable----------------------------------------------------------------------------------module Data.Generics.Internal.Families- ( module Families- , ShowSymbols- ) where--import Data.Generics.Internal.Families.Collect as Families-import Data.Generics.Internal.Families.Has as Families-import Data.Generics.Internal.Families.Changing as Families--import GHC.TypeLits (ErrorMessage (..), Symbol)--type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where- ShowSymbols '[]- = 'Text ""- ShowSymbols (c ': cs)- = 'Text "• " ':<>: 'Text c ':$$: ShowSymbols cs
− src/Data/Generics/Internal/Families/Changing.hs
@@ -1,145 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module Data.Generics.Internal.Families.Changing- ( Proxied- , Infer- ) where--import GHC.TypeLits (TypeError, ErrorMessage (..))-import Data.Type.Bool (If)--{-- Note [Changing type parameters]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-- To get good type inference for type-changing lenses, we want to be able- map the field's type back to the type argument it corresponds to. This way,- when the field is changed, we know what the result type of the structure is- going to be.-- However, for a given type @t@, its representation @Rep t@ forgets which types- in the structure came from type variables, and which didn't. An @Int@ that- results from the instantiation of the type paremeter and an @Int@ that was- monomorphically specified in the structure are indistinguishable.-- The solution is to replace the type arguments in the type with unique- proxies, like: @T a b@ -> @T (P 1 a) (P 0 b)@. This way, if looking up- a field's type yields something of shape @P _ _@, we know it came from a type- parameter, and also know which.-- If the field's type is a proxy, then its type is allowed to change, otherwise- not. This also allows us to satisfy the functional dependency @s field b -> t@.- If after doing the conversion on @s@, @field@'s type is @(P _ a), then @t@ is- @s[b/a]@, otherwise @t ~ s@ and @b ~ a@.--}---- `P` can be used in place of any type parameter, which means that it can have--- any kind, not just *, so a data type won't work.--- (this caused https://github.com/kcsongor/generic-lens/issues/23)--- Instead, we use a matchable type family to wrap any `k` - however, we can no longer directly--- pattern match on `P`, as it's not a type constructor. But we can still take it apart as a polymorphic--- application form. In order to distinguish between applications of P and other type constructors, we use a tag, `PTag`--- to fake a type constructor.-data PTag = PTag-type family P :: Peano -> k -> PTag -> k--type Proxied t = Proxied' t 'Z--type family Proxied' (t :: k) (next :: Peano) :: k where- Proxied' (t (a :: j) :: k) next = (Proxied' t ('S next)) (P next a 'PTag)- Proxied' t _ = t--data Sub where- Sub :: Peano -> k -> Sub--type family Unify (a :: k) (b :: k) :: [Sub] where- Unify (a b) a' = If (IsPTag b) '[HandleP (a b) a'] (HandleOther (a b) a')- Unify a a = '[]- Unify a b = TypeError- ( 'Text "Couldn't match type "- ':<>: 'ShowType a- ':<>: 'Text " with "- ':<>: 'ShowType b- )--type family HandleP a b where- HandleP (p n _ 'PTag) a' = 'Sub n a'--type family HandleOther a b where- HandleOther (a x) (b y) = Unify x y ++ Unify a b- HandleOther a a = '[]- HandleOther a b = TypeError- ( 'Text "Couldn't match type "- ':<>: 'ShowType a- ':<>: 'Text " with "- ':<>: 'ShowType b- )--type family IsPTag (a :: k) :: Bool where- IsPTag 'PTag = 'True- IsPTag _ = 'False--type family (xs :: [k]) ++ (ys :: [k]) :: [k] where- '[] ++ ys = ys- (x ': xs) ++ ys = x ': (xs ++ ys)--type family Infer (s :: *) (a' :: *) (b :: *) :: * where- Infer (s a) a' b- = ReplaceArgs (s a) (Unify a' b)- Infer s _ _ = s------------------------------------------------------------------------------------data Peano = Z | S Peano---- [TODO]: work this out------type family ArgKind (t :: k) (pos :: Peano) :: * where--- ArgKind (t (a :: k)) 'Z = k--- ArgKind (t _) ('S pos) = ArgKind t pos------type family ReplaceArg (t :: k) (pos :: Peano) (to :: ArgKind t pos) :: k where--- ReplaceArg (t a) 'Z to = t to--- ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a--- ReplaceArg t _ _ = t--type family ReplaceArg (t :: k) (pos :: Peano) (to :: j) :: k where- ReplaceArg (t a) 'Z to = t to- ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a- ReplaceArg t _ _ = t--type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where- ReplaceArgs t '[] = t- ReplaceArgs t ('Sub n arg ': ss) = ReplaceArgs (ReplaceArg t n arg) ss---- Note [CPP in instance constraints]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ In GHC 8.0.2, the calculated size of the expressions is too large for the--- inliner to consider them under the default -funfolding-use-threshold value--- (60).------ To reduce the size, the constraints------ ```--- s' ~ Proxied s--- t' ~ Proxied t--- ```------ are written as the following single equality:------ ```--- '(s', t') ~ '(Proxied s, Proxied t)--- ```------ However, for some reason, this violates the functional dependencies on 8.2.2.--- Therefore, when using a newer version of the compiler, the original constraints--- are used, as the expression size is smaller under 8.2.2.
− src/Data/Generics/Internal/Families/Collect.hs
@@ -1,132 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Generics.Internal.Families.Collect--- Copyright : (C) 2017 Csongor Kiss--- License : BSD3--- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability : experimental--- Portability : non-portable----------------------------------------------------------------------------------module Data.Generics.Internal.Families.Collect- ( CollectTotalType- , CollectPartialType- , CollectField- , CollectFieldsOrdered- , TypeStat (..)- , type (\\)- ) where--import Data.Type.Bool (If)-import Data.Type.Equality (type (==))-import GHC.Generics-import GHC.TypeLits (Symbol, CmpSymbol)--import Data.Generics.Internal.HList--data TypeStat- = TypeStat- { _containsNone :: [Symbol]- , _containsMultiple :: [Symbol]- , _containsOne :: [Symbol]- }--type EmptyStat = 'TypeStat '[] '[] '[]--type family CollectTotalType t f :: TypeStat where- CollectTotalType t (C1 ('MetaCons ctor _ _) f)- = AddToStat ctor (CountType t f) EmptyStat- CollectTotalType t (M1 _ _ r)- = CollectTotalType t r- CollectTotalType t (l :+: r)- = MergeStat (CollectTotalType t l) (CollectTotalType t r)--type family CollectField t f :: TypeStat where- CollectField t (C1 ('MetaCons ctor _ _) f)- = AddToStat ctor (CountField t f) EmptyStat- CollectField t (M1 _ _ r)- = CollectField t r- CollectField t (l :+: r)- = MergeStat (CollectField t l) (CollectField t r)--type family AddToStat (ctor :: Symbol) (count :: Count) (st :: TypeStat) :: TypeStat where- AddToStat ctor 'None ('TypeStat n m o) = 'TypeStat (ctor ': n) m o- AddToStat ctor 'Multiple ('TypeStat n m o) = 'TypeStat n (ctor ': m) o- AddToStat ctor 'One ('TypeStat n m o) = 'TypeStat n m (ctor ': o)--type family MergeStat (st1 :: TypeStat) (st2 :: TypeStat) :: TypeStat where- MergeStat ('TypeStat n m o) ('TypeStat n' m' o') = 'TypeStat (n ++ n') (m ++ m') (o ++ o')--type family CountType t f :: Count where- CountType t (S1 _ (Rec0 t))- = 'One- CountType t (l :*: r)- = CountType t l <|> CountType t r- CountType t _- = 'None--type family CountField (field :: Symbol) f :: Count where- CountField field (S1 ('MetaSel ('Just field) _ _ _) _)- = 'One- CountField field (l :*: r)- = CountField field l <|> CountField field r- CountField _ _- = 'None--type family CollectPartialType t f :: [Symbol] where- CollectPartialType t (l :+: r)- = CollectPartialType t l ++ CollectPartialType t r- CollectPartialType t (C1 ('MetaCons ctor _ _) f)- = If (t == ListToTuple (GCollect f)) '[ctor] '[]- CollectPartialType t (D1 _ f)- = CollectPartialType t f--data Count- = None- | One- | Multiple--type family (a :: Count) <|> (b :: Count) :: Count where- 'None <|> b = b- a <|> 'None = a- a <|> b = 'Multiple--type family (a :: Count) <&> (b :: Count) :: Count where- a <&> a = a- _ <&> _ = 'Multiple--type family CollectFieldsOrdered (r :: * -> *) :: [Symbol] where- CollectFieldsOrdered (l :*: r)- = Merge (CollectFieldsOrdered l) (CollectFieldsOrdered r)- CollectFieldsOrdered (S1 ('MetaSel ('Just name) _ _ _) _)- = '[name]- CollectFieldsOrdered (M1 _ m a)- = CollectFieldsOrdered a- CollectFieldsOrdered _- = '[]--type family Merge (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where- Merge xs '[] = xs- Merge '[] ys = ys- Merge (x ': xs) (y ': ys) = Merge' (CmpSymbol x y) x y xs ys--type family Merge' (ord :: Ordering) (x :: Symbol) (y :: Symbol) (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where- Merge' 'LT x y xs ys = x ': Merge xs (y ': ys)- Merge' _ x y xs ys = y ': Merge (x ': xs) ys--type family (xs :: [Symbol]) \\ (ys :: [Symbol]) :: [Symbol] where- xs \\ '[] = xs- '[] \\ xs = '[]- (x ': xs) \\ (y ': ys) = Sub' (CmpSymbol x y) x y xs ys--infixr 5 \\-type family Sub' (ord :: Ordering) (x :: Symbol) (y :: Symbol) (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where- Sub' 'LT x y xs ys = x ': (xs \\ y ': ys)- Sub' 'GT x _ xs ys = (x ': xs) \\ ys- Sub' 'EQ _ _ xs ys = xs \\ ys
− src/Data/Generics/Internal/Families/Has.hs
@@ -1,97 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Generics.Internal.Families.Has--- Copyright : (C) 2017 Csongor Kiss--- License : BSD3--- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability : experimental--- Portability : non-portable----------------------------------------------------------------------------------module Data.Generics.Internal.Families.Has- ( HasTotalFieldP- , HasTotalTypeP- , HasPartialTypeTupleP- , HasCtorP- ) where--import Data.Type.Bool (type (||), type (&&))-import Data.Type.Equality (type (==))-import GHC.Generics-import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))--import Data.Generics.Internal.HList--type family HasTotalFieldP (field :: Symbol) f :: Bool where- HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)- = 'True- HasTotalFieldP field (l :*: r)- = HasTotalFieldP field l || HasTotalFieldP field r- HasTotalFieldP field (l :+: r)- = HasTotalFieldP field l && HasTotalFieldP field r- HasTotalFieldP field (S1 _ _)- = 'False- HasTotalFieldP field (C1 _ f)- = HasTotalFieldP field f- HasTotalFieldP field (D1 _ f)- = HasTotalFieldP field f- HasTotalFieldP field (Rec0 _)- = 'False- HasTotalFieldP field U1- = 'False- HasTotalFieldP field V1- = 'False- HasTotalFieldP field f- = TypeError- ( 'ShowType f- ':<>: 'Text " is not a valid GHC.Generics representation type"- )--type family HasTotalTypeP a f :: Bool where- HasTotalTypeP t (S1 meta (Rec0 t))- = 'True- HasTotalTypeP t (l :*: r)- = HasTotalTypeP t l || HasTotalTypeP t r- HasTotalTypeP t (l :+: r)- = HasTotalTypeP t l && HasTotalTypeP t r- HasTotalTypeP t (S1 _ _)- = 'False- HasTotalTypeP t (C1 m f)- = HasTotalTypeP t f- HasTotalTypeP t (D1 m f)- = HasTotalTypeP t f- HasTotalTypeP t (Rec0 _)- = 'False- HasTotalTypeP t U1- = 'False- HasTotalTypeP t V1- = 'False- HasTotalTypeP t f- = TypeError- ( 'ShowType f- ':<>: 'Text " is not a valid GHC.Generics representation type"- )--type family HasPartialTypeTupleP a f :: Bool where- HasPartialTypeTupleP t (l :+: r)- = HasPartialTypeTupleP t l || HasPartialTypeTupleP t r- HasPartialTypeTupleP t (C1 m f)- = t == ListToTuple (GCollect f)- HasPartialTypeTupleP t _- = 'False--type family HasCtorP (ctor :: Symbol) f :: Bool where- HasCtorP ctor (C1 ('MetaCons ctor _ _) _)- = 'True- HasCtorP ctor (f :+: g)- = HasCtorP ctor f || HasCtorP ctor g- HasCtorP ctor (D1 m f)- = HasCtorP ctor f- HasCtorP ctor _- = 'False
− src/Data/Generics/Internal/HList.hs
@@ -1,239 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Generics.Internal.HList--- Copyright : (C) 2017 Csongor Kiss--- License : BSD3--- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability : experimental--- Portability : non-portable----------------------------------------------------------------------------------module Data.Generics.Internal.HList- ( type (++)-- , ListTuple (..)-- , GCollectible (..)- ) where--import Data.Kind (Type)-import GHC.Generics--data HList (xs :: [Type]) where- Nil :: HList '[]- (:>) :: x -> HList xs -> HList (x ': xs)--infixr 5 :>--type family ((as :: [k]) ++ (bs :: [k])) :: [k] where- '[] ++ bs = bs- (a ': as) ++ bs = a ': as ++ bs--append :: HList as -> HList bs -> HList (as ++ bs)-append Nil ys = ys-append (x :> xs) ys = x :> append xs ys--head' :: HList (a ': as) -> a-head' (x :> _) = x------------------------------------------------------------------------------------- * Split HList--class Splittable (as :: [Type]) (bs :: [Type]) (cs :: [Type]) | as bs -> cs, as cs -> bs where- split :: HList cs -> (HList as, HList bs)--instance Splittable '[] bs bs where- split bs = (Nil, bs)--instance Splittable as bs cs => Splittable (a ': as) bs (a ': cs) where- split (a :> as)- = (a :> as', bs)- where (as', bs) = split as------------------------------------------------------------------------------------- * Convert tuples to/from HLists--class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where- type ListToTuple as :: Type- tupleToList :: tuple -> HList as- listToTuple :: HList as -> tuple--instance ListTuple () '[] where- type ListToTuple '[] = ()- tupleToList _ = Nil- listToTuple _ = ()--instance ListTuple a '[a] where- type ListToTuple '[a] = a- tupleToList a- = a :> Nil- listToTuple (a :> Nil)- = a--instance ListTuple (a, b) '[a, b] where- type ListToTuple '[a, b] = (a, b)- tupleToList (a, b)- = a :> b :> Nil- listToTuple (a :> b :> Nil)- = (a, b)--instance ListTuple (a, b, c) '[a, b, c] where- type ListToTuple '[a, b, c] = (a, b, c)- tupleToList (a, b, c)- = a :> b :> c :> Nil- listToTuple (a :> b :> c :> Nil)- = (a, b, c)--instance ListTuple (a, b, c, d) '[a, b, c, d] where- type ListToTuple '[a, b, c, d] = (a, b, c, d)- tupleToList (a, b, c, d)- = a :> b :> c :> d:> Nil- listToTuple (a :> b :> c :> d :> Nil)- = (a, b, c, d)--instance ListTuple (a, b, c, d, e) '[a, b, c, d, e] where- type ListToTuple '[a, b, c, d, e] = (a, b, c, d, e)- tupleToList (a, b, c, d, e)- = a :> b :> c :> d:> e :> Nil- listToTuple (a :> b :> c :> d :> e :> Nil)- = (a, b, c, d, e)--instance ListTuple (a, b, c, d, e, f) '[a, b, c, d, e, f] where- type ListToTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)- tupleToList (a, b, c, d, e, f)- = a :> b :> c :> d:> e :> f :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> Nil)- = (a, b, c, d, e, f)--instance ListTuple (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where- type ListToTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)- tupleToList (a, b, c, d, e, f, g)- = a :> b :> c :> d:> e :> f :> g :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)- = (a, b, c, d, e, f, g)--instance ListTuple (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where- type ListToTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)- tupleToList (a, b, c, d, e, f, g, h)- = a :> b :> c :> d:> e :> f :> g :> h :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)- = (a, b, c, d, e, f, g, h)--instance ListTuple (a, b, c, d, e, f, g, h, j) '[a, b, c, d, e, f, g, h, j] where- type ListToTuple '[a, b, c, d, e, f, g, h, j] = (a, b, c, d, e, f, g, h, j)- tupleToList (a, b, c, d, e, f, g, h, j)- = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)- = (a, b, c, d, e, f, g, h, j)--instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[a, b, c, d, e, f, g, h, j, k] where- type ListToTuple '[a, b, c, d, e, f, g, h, j, k] = (a, b, c, d, e, f, g, h, j, k)- tupleToList (a, b, c, d, e, f, g, h, j, k)- = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)- = (a, b, c, d, e, f, g, h, j, k)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j, k, l] where- type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l] = (a, b, c, d, e, f, g, h, j, k, l)- tupleToList (a, b, c, d, e, f, g, h, j, k, l)- = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)- = (a, b, c, d, e, f, g, h, j, k, l)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[a, b, c, d, e, f, g, h, j, k, l, m] where- type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m] = (a, b, c, d, e, f, g, h, j, k, l, m)- tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)- = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)- = (a, b, c, d, e, f, g, h, j, k, l, m)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[a, b, c, d, e, f, g, h, j, k, l, m, n] where- type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n] = (a, b, c, d, e, f, g, h, j, k, l, m, n)- tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)- = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)- = (a, b, c, d, e, f, g, h, j, k, l, m, n)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] where- type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)- tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)- = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)- = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] where- type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)- tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)- = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)- = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] where- type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)- tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)- = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)- = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] where- type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)- tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)- = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)- = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] where- type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)- tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)- = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil- listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)- = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)------------------------------------------------------------------------------------class GCollectible (f :: Type -> Type) (as :: [Type]) | f -> as where- type GCollect f :: [Type]- gtoCollection :: f x -> HList as- gfromCollection :: HList as -> f x--instance- ( GCollectible l as- , GCollectible r bs- , cs ~ (as ++ bs)- , Splittable as bs cs- ) => GCollectible (l :*: r) cs where- type GCollect (l :*: r) = GCollect l ++ GCollect r-- gtoCollection (l :*: r)- = gtoCollection l `append` gtoCollection r-- gfromCollection cs- = gfromCollection as :*: gfromCollection bs- where (as, bs) = split cs--instance GCollectible (Rec0 a) '[a] where- type GCollect (Rec0 a) = '[a]- gtoCollection = (:> Nil) . unK1- gfromCollection = K1 . head'--instance GCollectible U1 '[] where- type GCollect U1 = '[]- gtoCollection U1 = Nil- gfromCollection Nil = U1--instance GCollectible f as => GCollectible (M1 m meta f) as where- type GCollect (M1 m meta f) = GCollect f- gtoCollection = gtoCollection . unM1- gfromCollection = M1 . gfromCollection
− src/Data/Generics/Internal/Lens.hs
@@ -1,143 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Module : Data.Generics.Internal.Lens--- Copyright : (C) 2017 Csongor Kiss--- License : BSD3--- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability : experimental--- Portability : non-portable------ Internal lens helpers. Only exported for Haddock----------------------------------------------------------------------------------module Data.Generics.Internal.Lens where--import Control.Applicative (Const(..))-import Data.Functor.Identity (Identity(..))-import Data.Monoid (First (..))-import Data.Profunctor (Choice(right'), Profunctor(dimap))-import Data.Profunctor.Unsafe ((#.), (.#))-import Data.Tagged-import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), Rep)---- | 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---- | Type alias for prism-type Prism s t a b- = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)--type Prism' s a- = Prism s s a a--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)---- | Getting-(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a-s ^. l = getConst (l Const s)-infixl 8 ^.---- | Setting-set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t-set l b- = runIdentity . l (\_ -> Identity b)--infixr 4 .~-(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t-(.~) = set--infixl 8 ^?-(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a-s ^? l = getFirst (fmof l (First #. Just) s)- where fmof l' f = getConst #. l' (Const #. f)--infixr 8 #-(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t-(#) p = runIdentity #. unTagged #. p .# Tagged .# Identity---- | Lens focusing on the first element of a product-first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)-first f (a :*: b)- = fmap (:*: b) (f a)---- | Lens focusing on the second element of a product-second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)-second f (a :*: b)- = fmap (a :*:) (f b)--left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)-left = prism L1 $ gsum Right (Left . R1)--right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)-right = prism R1 $ gsum (Left . L1) Right--gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c-gsum f _ (L1 x) = f x-gsum _ g (R1 y) = g y--combine :: Lens' (s x) a -> Lens' (t x) a -> Lens' ((s :+: t) x) a-combine sa _ f (L1 s) = fmap (\a -> L1 (set sa a s)) (f (s ^. sa))-combine _ ta f (R1 t) = fmap (\a -> R1 (set ta a t)) (f (t ^. ta))--prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b-prism bt seta = dimap seta (either pure (fmap bt)) . right'---- | A type and its generic representation are isomorphic-repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)-repIso = dimap from (fmap to)---- | 'M1' is just a wrapper around `f p`---mIso :: Iso' (M1 i c f p) (f p)-mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)-mIso = dimap unM1 (fmap M1)---- These are specialised versions of the Isos above. On GHC 8.0.2, having--- these functions eta-expanded allows the optimiser to inline these functions.-mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)-mLens f s = mIso f s--repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)-repLens f s = repIso f s--sumIso :: Iso' ((a :+: b) x) (Either (a x) (b x))-sumIso = dimap f (fmap t)- where f (L1 x) = Left x- f (R1 x) = Right x- t (Left x) = L1 x- t (Right x) = R1 x--_Left :: Prism' (Either a c) a-_Left = prism Left $ either Right (Left . Right)--_Right :: Prism' (Either c a) a-_Right = prism Right $ either (Left . Left) Right------------------------------------------------------------------------------------data Coyoneda f b = forall a. Coyoneda (a -> b) (f a)--instance Functor (Coyoneda f) where- fmap f (Coyoneda g fa)- = Coyoneda (f . g) fa--inj :: Functor f => Coyoneda f a -> f a-inj (Coyoneda f a) = fmap f a--proj :: Functor f => f a -> Coyoneda f a-proj fa = Coyoneda id fa--ravel :: Functor f => ((a -> Coyoneda f b) -> s -> Coyoneda f t) -> (a -> f b) -> (s -> f t)-ravel coy f s = inj $ coy (\a -> proj (f a)) s
+ src/Data/Generics/Internal/VL.hs view
@@ -0,0 +1,14 @@+{-# 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+
+ src/Data/Generics/Internal/VL/Iso.hs view
@@ -0,0 +1,93 @@+{-# 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 <kiss.csongor.kiss@gmail.com>+-- 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 #-}
+ src/Data/Generics/Internal/VL/Lens.hs view
@@ -0,0 +1,72 @@+{-# 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 <kiss.csongor.kiss@gmail.com>+-- 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 #-}+
+ src/Data/Generics/Internal/VL/Prism.hs view
@@ -0,0 +1,85 @@+{-# 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 <kiss.csongor.kiss@gmail.com>+-- 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' #-}
− src/Data/Generics/Internal/Void.hs
@@ -1,18 +0,0 @@-module Data.Generics.Internal.Void where--{-- Note [Uncluttering type signatures]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-- Because the various instances in the library always match (the Has* classes- are essentially glorified constraint synonyms), they get replaced with- their constraints, resulting in large, unreadable types.-- Writing an (overlapping instance) for this Void type means that the original- instance might not be the one selected, thus GHC leaves the constraints in- place until further information is provided, at which point the type- machinery has sufficient information to reduce to sensible types.--}-data Void-data Void1 a-data Void2 a b
+ src/Data/Generics/Labels.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#if MIN_VERSION_base(4,12,0)+{-# LANGUAGE NoStarIsType #-}+#endif+{-# 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 <kiss.csongor.kiss@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Provides an (orphan) IsLabel instance for field lenses and constructor+-- prisms, as well as positional lenses on GHC >=9.6.+-- 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 ...+-- @+--+-- Starting with GHC 9.6, you can also write e.g. @#2@ and @#15@ instead of+-- @position \@1@ and @position \@15@, so we morally have+--+-- @+-- instance (HasPosition i s t a b) => IsLabel (Show i) (Lens 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 | PositionType++type family ClassifyLabel (name :: Symbol) :: LabelType where+ ClassifyLabel name =+ If (StartsWithDigit name)+ 'PositionType+ ( If (StartsWithUnderscoreAndUpperCase name)+ 'LegacyConstrType+ ( If (StartsWithUpperCase name)+ 'ConstrType+ 'FieldType+ )+ )++type StartsWithDigit name =+ CmpSymbol "/" name == 'LT && CmpSymbol ":" name == 'GT++type StartsWithUnderscoreAndUpperCase name =+ CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT++type StartsWithUpperCase name =+ CmpSymbol "@" name == 'LT && CmpSymbol "[" name == 'GT++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.+--+-- On GHC >=9.6, we also check whether the symbol starts with a digit, in which+-- case we are dealing with an index for a positional 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++class Position (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a -> s where+ positionLens :: Lens s t a b++instance {-# INCOHERENT #-} HasPosition i s t a b => Position i s t a b where+ positionLens = position @i++instance {-# INCOHERENT #-} HasPosition' i s a => Position i s s a a where+ positionLens = position' @i++instance ( Functor f, Position i s t a b, i ~ ParseNat name+ ) => IsLabelHelper 'PositionType name (->) f s t a b where+ labelOutput = positionLens @i++-- 'ParseNat' is only necessary for positional lenses, which can only actually+-- be used with OverloadedLabels since GHC 9.6. Therefore, it is fine that this+-- code only compiles with GHC >=9.4 due to the use of newer GHC features (such+-- as 'UnconsSymbol').+#if MIN_VERSION_base(4,17,0)+type ParseNat name = ParseNat' 0 (UnconsSymbol name)++type family ParseNat' acc m where+ ParseNat' acc ('Just '(hd, tl)) =+ ParseNat' (10 * acc + DigitToNat hd) (UnconsSymbol tl)+ ParseNat' acc 'Nothing = acc++type DigitToNat c =+ If ('0' <=? c && c <=? '9')+ (CharToNat c - CharToNat '0')+ (TypeError ('Text "Invalid position number"))+#else+type family ParseNat name where+ ParseNat name = TypeError ('Text "Positional lenses not supported")+#endif
src/Data/Generics/Product.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE PackageImports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product--- Copyright : (C) 2017 Csongor Kiss+-- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability : experimental@@ -22,10 +23,17 @@ , 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 Data.Generics.Product.Any-import Data.Generics.Product.Fields-import Data.Generics.Product.Positions-import Data.Generics.Product.Subtype-import Data.Generics.Product.Typed+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
src/Data/Generics/Product/Any.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}@@ -12,7 +13,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Any--- Copyright : (C) 2017 Csongor Kiss+-- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability : experimental@@ -29,10 +30,10 @@ HasAny (..) ) where -import Data.Generics.Internal.Lens-import Data.Generics.Product.Fields-import Data.Generics.Product.Positions-import Data.Generics.Product.Typed+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:/@@ -41,7 +42,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :{ -- data Human = Human -- { name :: String@@ -53,7 +54,7 @@ -- human = Human "Tunyasz" 50 "London" -- :} -class HasAny (sel :: k) s t a b | s sel k -> a where+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'
src/Data/Generics/Product/Fields.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -16,7 +17,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Fields--- Copyright : (C) 2017 Csongor Kiss+-- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability : experimental@@ -31,21 +32,20 @@ -- $setup HasField (..)- , HasField'+ , HasField' (..)+ , HasField_ (..) , getField , setField ) where -import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens-import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.Fields+import "this" Data.Generics.Internal.VL.Lens as VL -import Data.Kind (Constraint, Type)-import GHC.Generics-import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)+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:/ --@@ -55,7 +55,7 @@ -- >>> :set -XGADTs -- >>> :set -XFlexibleContexts -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :m +Data.Function -- >>> :{ -- data Human a@@ -76,7 +76,7 @@ -- :} -- |Records that have a field with a given name.-class HasField (field :: Symbol) s t a b | s field -> a, s field b -> t, t field a -> s where+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. --@@ -108,67 +108,70 @@ -- ... The offending constructors are: -- ... HumanNoAddress -- ...- field :: Lens s t a b+ field :: VL.Lens s t a b -type HasField' field s a = HasField field s s a a+-- |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 s a. HasField' f s a => s -> a-getField s = s ^. field @f+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 = set (field @f)+setField = VL.set (field' @f) -instance -- see Note [Changing type parameters]- ( Generic s- , ErrorUnless field s (CollectField field (Rep s))- , Generic t- -- see Note [CPP in instance constraints]-#if __GLASGOW_HASKELL__ < 802- , '(s', t') ~ '(Proxied s, Proxied t)-#else- , s' ~ Proxied s- , t' ~ Proxied t-#endif- , Generic s'- , Generic t'- , GHasField' field (Rep s) a- , GHasField' field (Rep s') a'- , GHasField' field (Rep t') b'- , GHasField field (Rep s) (Rep t) a b- , t ~ Infer s a' b- , s ~ Infer t b' a- ) => HasField field s t a b where+instance Core.Context' field s a => HasField' field s a where+ field' f s = field0 @field f s - field f s = ravel (repLens . gfield @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 --- -- See Note [Uncluttering type signatures]+-- 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 -type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where- ErrorUnless field s ('TypeStat _ _ '[])- = TypeError- ( 'Text "The type "- ':<>: 'ShowType s- ':<>: 'Text " does not contain a field named '"- ':<>: 'Text field ':<>: 'Text "'."- )+instance {-# OVERLAPPING #-} HasField' f (Void1 a) a where+ field' = undefined - ErrorUnless field s ('TypeStat (n ': ns) _ _)- = TypeError- ( 'Text "Not all constructors of the type "- ':<>: 'ShowType s- ':$$: 'Text " contain a field named '"- ':<>: 'Text field ':<>: 'Text "'."- ':$$: 'Text "The offending constructors are:"- ':$$: ShowSymbols (n ': ns)- )+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 - ErrorUnless _ _ ('TypeStat '[] '[] _)- = ()+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 #-}
+ src/Data/Generics/Product/HList.hs view
@@ -0,0 +1,49 @@+{-# 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 <kiss.csongor.kiss@gmail.com>+-- 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 #-}
− src/Data/Generics/Product/Internal/Fields.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Generics.Product.Internal.Fields--- Copyright : (C) 2017 Csongor Kiss--- License : BSD3--- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability : experimental--- Portability : non-portable------ Derive record field getters and setters generically.-----------------------------------------------------------------------------------module Data.Generics.Product.Internal.Fields- ( GHasField (..)- , GHasField'- ) where--import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens--import Data.Kind (Type)-import GHC.Generics-import GHC.TypeLits (Symbol)---- |As 'HasField' but over generic representations as defined by--- "GHC.Generics".-class GHasField (field :: Symbol) (s :: Type -> Type) (t :: Type -> Type) a b | s field -> a, t field -> b where- gfield :: Lens (s x) (t x) a b--type GHasField' field s a = GHasField field s s a a--instance GProductHasField field l r l' r' a b (HasTotalFieldP field l)- => GHasField field (l :*: r) (l' :*: r') a b where-- gfield = gproductField @field @_ @_ @_ @_ @_ @_ @(HasTotalFieldP field l)--instance (GHasField' field r a, GHasField' field l a, GHasField field l l' a b, GHasField field r r' a b)- => GHasField field (l :+: r) (l' :+: r') a b where-- gfield f (L1 s) = fmap (\a -> L1 (set (gfield @field) a s)) (f (s ^. gfield @field))- gfield f (R1 t) = fmap (\a -> R1 (set (gfield @field) a t)) (f (t ^. gfield @field))--instance GHasField field (K1 R a) (K1 R b) a b where- gfield f (K1 x) = fmap K1 (f x)--instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 b)) a b where- gfield = mLens . gfield @field--instance (Functor g, GHasField field f g a b) => GHasField field (M1 D meta f) (M1 D meta g) a b where- gfield = mLens . gfield @field--instance GHasField field f g a b => GHasField field (M1 C meta f) (M1 C meta g) a b where- gfield = mLens . gfield @field--class GProductHasField (field :: Symbol) l r l' r' a b (left :: Bool) | field l r -> a, field l' r' -> b where- gproductField :: Lens ((l :*: r) x) ((l' :*: r') x) a b--instance GHasField field l l' a b => GProductHasField field l r l' r a b 'True where- gproductField = first . gfield @field--instance GHasField field r r' a b => GProductHasField field l r l r' a b 'False where- gproductField = second . gfield @field
− src/Data/Generics/Product/Internal/Positions.hs
@@ -1,90 +0,0 @@-{-# 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.Internal.Positions--- Copyright : (C) 2017 Csongor Kiss--- License : BSD3--- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability : experimental--- Portability : non-portable------ Derive positional product type getters and setters generically.-----------------------------------------------------------------------------------module Data.Generics.Product.Internal.Positions- ( GHasPosition (..)- , GHasPosition'- , type (<?)- , Size- ) where--import Data.Generics.Internal.Lens--import Data.Kind (Type)-import Data.Type.Bool (If, Not)-import GHC.Generics-import GHC.TypeLits (type (<=?), type (+), Nat)---- |As 'HasPosition' but over generic representations as defined by--- "GHC.Generics".-class GHasPosition (offset :: Nat) (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s offset i -> a, s t offset i -> b where- gposition :: Lens (s x) (t x) a b--type GHasPosition' i s a = GHasPosition 1 i s s a a--instance GHasPosition i i (K1 R a) (K1 R b) a b where- gposition f (K1 x) = fmap K1 (f x)--instance GHasPosition offset i s t a b => GHasPosition offset i (M1 m meta s) (M1 m meta t) a b where- gposition = mLens . gposition @offset @i--instance- ( goLeft ~ (i <? (offset + Size l))- , offset' ~ (If goLeft offset (offset + Size l))- , GProductHasPosition offset' i l r l' r' a b goLeft- ) => GHasPosition offset i (l :*: r) (l' :*: r') a b where-- gposition = gproductPosition @offset' @i @_ @_ @_ @_ @_ @_ @goLeft--class GProductHasPosition (offset :: Nat) (i :: Nat) l r l' r' a b (left :: Bool) | offset i l r -> a, offset i l r l' r' -> b where- gproductPosition :: Lens ((l :*: r) x) ((l' :*: r') x) a b--instance GHasPosition offset i l l' a b => GProductHasPosition offset i l r l' r a b 'True where- gproductPosition = first . gposition @offset @i--instance GHasPosition offset i r r' a b => GProductHasPosition offset i l r l r' a b 'False where- gproductPosition = second . gposition @offset @i--type family Size f :: Nat where- Size (l :*: r)- = Size l + Size r- Size (l :+: r)- = Min (Size l) (Size r)- Size (D1 meta f)- = Size f- Size (C1 meta f)- = Size f- Size f- = 1------------------------------------------------------------------------------------type x <? y = Not (y <=? x)-infixl 4 <?--type Min a b = If (a <? b) a b
− src/Data/Generics/Product/Internal/Subtype.hs
@@ -1,92 +0,0 @@-{-# 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.Internal.Subtype--- Copyright : (C) 2017 Csongor Kiss--- License : BSD3--- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability : experimental--- Portability : non-portable------ Structural subtype relationships between product types.-----------------------------------------------------------------------------------module Data.Generics.Product.Internal.Subtype- ( GUpcast (..)- , GSmash (..)- ) where--import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens-import Data.Generics.Product.Internal.Fields--import Data.Kind (Type)-import GHC.Generics------------------------------------------------------------------------------------- * Generic upcasting--class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where- gupcast :: sub p -> sup p--instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where- gupcast rep = gupcast rep :*: gupcast rep--instance- GHasField field sub sub t t- => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where-- gupcast r = M1 (K1 (r ^. gfield @field))--instance GUpcast sub sup => GUpcast sub (C1 c sup) where- gupcast = M1 . gupcast--instance GUpcast sub sup => GUpcast sub (D1 c sup) where- gupcast = M1 . gupcast------------------------------------------------------------------------------------- * Generic smashing--class GSmash sub sup where- gsmash :: sup p -> sub p -> sub p--instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where- gsmash rep (a :*: b) = gsmash rep a :*: gsmash rep b--instance- ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)- , GSmashLeaf leaf sup (HasTotalFieldP field sup)- ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where-- gsmash = gsmashLeaf @_ @_ @(HasTotalFieldP field sup)--instance GSmash sub sup => GSmash (C1 c sub) sup where- gsmash sup (M1 sub) = M1 (gsmash sup sub)--instance GSmash sub sup => GSmash (D1 c sub) sup where- gsmash sup (M1 sub) = M1 (gsmash sup sub)--class GSmashLeaf sub sup (w :: Bool) where- gsmashLeaf :: sup p -> sub p -> sub p--instance- GHasField field sup sup t t- => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where- gsmashLeaf sup _ = M1 (K1 (sup ^. gfield @field))--instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where- gsmashLeaf _ = id
− src/Data/Generics/Product/Internal/Typed.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Generics.Product.Internal.Typed--- Copyright : (C) 2017 Csongor Kiss--- License : BSD3--- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability : experimental--- Portability : non-portable------ Derive record field getters and setters generically.-----------------------------------------------------------------------------------module Data.Generics.Product.Internal.Typed- ( GHasType (..)- ) where--import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens--import Data.Kind (Type)-import GHC.Generics---- |As 'HasType' but over generic representations as defined by--- "GHC.Generics".-class GHasType (f :: Type -> Type) a where- gtyped :: Lens' (f x) a--instance GProductHasType l r a (HasTotalTypeP a l)- => GHasType (l :*: r) a where-- gtyped = gproductTyped @_ @_ @_ @(HasTotalTypeP a l)--instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where- gtyped = combine (gtyped @l) (gtyped @r)--instance GHasType (K1 R a) a where- gtyped f (K1 x) = fmap K1 (f x)--instance GHasType f a => GHasType (M1 m meta f) a where- gtyped = mLens . gtyped--class GProductHasType l r a (contains :: Bool) where- gproductTyped :: Lens' ((l :*: r) x) a--instance GHasType l a => GProductHasType l r a 'True where- gproductTyped = first . gtyped--instance GHasType r a => GProductHasType l r a 'False where- gproductTyped = second . gtyped
+ src/Data/Generics/Product/Param.hs view
@@ -0,0 +1,51 @@+{-# 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 <kiss.csongor.kiss@gmail.com>+-- 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
src/Data/Generics/Product/Positions.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}@@ -17,7 +19,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Positions--- Copyright : (C) 2017 Csongor Kiss+-- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability : experimental@@ -32,22 +34,21 @@ -- $setup HasPosition (..)- , HasPosition'+ , HasPosition' (..)+ , HasPosition_ (..)+ , HasPosition0 (..) , getPosition , setPosition ) where -import Data.Generics.Internal.Lens-import Data.Generics.Internal.Void-import Data.Generics.Internal.Families-import Data.Generics.Product.Internal.Positions+import "this" Data.Generics.Internal.VL.Lens as VL -import Data.Kind (Constraint, Type)-import Data.Type.Bool (type (&&))-import GHC.Generics-import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))+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:/ --@@ -57,7 +58,7 @@ -- >>> :set -XGADTs -- >>> :set -XFlexibleContexts -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :m +Data.Function -- >>> :{ -- data Human = Human@@ -71,7 +72,7 @@ -- :} -- |Records that have a field at a given position.-class HasPosition (i :: Nat) s t a b | s i -> a, s i b -> t, t i a -> s where+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. --@@ -86,51 +87,62 @@ -- ... -- ... The type Human does not contain a field at position 4 -- ...- position :: Lens s t a b+ position :: VL.Lens s t a b -type HasPosition' i s a = HasPosition i s s a a+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+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 = set (position @i)+setPosition = VL.set (position' @i) -instance -- see Note [Changing type parameters]- ( Generic s- , ErrorUnless i s (0 <? i && i <=? Size (Rep s))- , Generic t- -- see Note [CPP in instance constraints]-#if __GLASGOW_HASKELL__ < 802- , '(s', t') ~ '(Proxied s, Proxied t)-#else- , s' ~ Proxied s- , t' ~ Proxied t-#endif- , Generic s'- , Generic t'- , GHasPosition' i (Rep s) a- , GHasPosition' i (Rep s') a'- , GHasPosition 1 i (Rep s) (Rep t) a b- , t ~ Infer s a' b- , GHasPosition' i (Rep t') b'- , s ~ Infer t b' a- ) => HasPosition i s t a b where+instance Core.Context' i s a => HasPosition' i s a where+ position' f s = VL.ravel (Core.derived' @i) f s+ {-# INLINE position' #-} - position f s = ravel (repLens . gposition @1 @i) f s+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 #-} --- See Note [Uncluttering type signatures]+-- | 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 -type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where- ErrorUnless i s 'False- = TypeError- ( 'Text "The type "- ':<>: 'ShowType s- ':<>: 'Text " does not contain a field at position "- ':<>: 'ShowType i- )+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_ #-} - ErrorUnless _ _ 'True- = ()+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 #-}
src/Data/Generics/Product/Subtype.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -15,7 +16,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Subtype--- Copyright : (C) 2017 Csongor Kiss+-- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability : experimental@@ -32,15 +33,14 @@ Subtype (..) ) where -import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens-import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.Subtype -import GHC.Generics (Generic (Rep, to, from) )-import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))-import Data.Kind (Type, Constraint)+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:/ --@@ -49,7 +49,7 @@ -- >>> :set -XDeriveGeneric -- >>> :set -XDuplicateRecordFields -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :{ -- data Human = Human -- { name :: String@@ -80,9 +80,10 @@ -- -- >>> set (super @Animal) (Animal "dog" 10) human -- Human {name = "dog", age = 10, address = "London"}- super :: Lens' sub sup- super f sub- = fmap (`smash` sub) (f (upcast sub))+ 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 --@@ -97,43 +98,37 @@ -- ... 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 = set (super @sup)+ smash = VL.set (super @sup)+ {-# INLINE smash #-} {-# MINIMAL super | smash, upcast #-} -instance- ( Generic a- , Generic b- , GSmash (Rep a) (Rep b)- , GUpcast (Rep a) (Rep b)- , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))- ) => Subtype b a where- smash p b = to $ gsmash (from p) (from b)- upcast = to . gupcast . from+instance Core.Context a b => Subtype b a where+ smash p b = to $ Core.gsmash (from p) (from b)+ upcast = to . Core.gupcast . from --- See Note [Uncluttering type signatures]+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--type family ErrorUnless (sup :: Type) (sub :: Type) (diff :: [Symbol]) :: Constraint where- ErrorUnless _ _ '[]- = ()-- ErrorUnless sup sub fs- = TypeError- ( 'Text "The type '"- ':<>: 'ShowType sub- ':<>: 'Text "' is not a subtype of '"- ':<>: 'ShowType sup ':<>: 'Text "'."- ':$$: 'Text "The following fields are missing from '"- ':<>: 'ShowType sub ':<>: 'Text "':"- ':$$: ShowSymbols fs- )
src/Data/Generics/Product/Typed.hs view
@@ -1,25 +1,21 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Typed--- Copyright : (C) 2017 Csongor Kiss+-- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability : experimental -- Portability : non-portable ----- Derive record field getters and setters generically.+-- Derive lenses of a given type in a product. -- ----------------------------------------------------------------------------- @@ -30,14 +26,10 @@ HasType (..) ) where -import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens-import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.Typed+import "this" Data.Generics.Internal.VL.Lens as VL -import Data.Kind (Constraint, Type)-import GHC.Generics (Generic (Rep))-import GHC.TypeLits (TypeError, ErrorMessage (..))+import qualified "generic-lens-core" Data.Generics.Product.Internal.Typed as Core+import "generic-lens-core" Data.Generics.Internal.Void -- $setup -- == /Running example:/@@ -46,7 +38,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :{ -- data Human -- = Human@@ -65,7 +57,8 @@ -- human = Human "Tunyasz" 50 "London" False -- :} --- |Records that have a field with a unique type.+-- |Types that contain another type, either by being a record with a field+-- with that type, or by actually being that 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.@@ -91,9 +84,10 @@ -- ... The offending constructors are: -- ... HumanNoTall -- ...- typed :: Lens' s a- typed f t- = fmap (flip (setTyped @a) t) (f (getTyped @a t))+ typed :: VL.Lens s s a a+ typed+ = VL.lens (getTyped @a) (flip (setTyped @a))+ {-# INLINE typed #-} -- |Get field at type. getTyped :: s -> a@@ -101,50 +95,27 @@ -- |Set field at type. setTyped :: a -> s -> s- setTyped = set (typed @a)+ setTyped = VL.set (typed @a) {-# MINIMAL typed | setTyped, getTyped #-} -instance- ( Generic s- , ErrorUnlessOne a s (CollectTotalType a (Rep s))- , GHasType (Rep s) a- ) => HasType a s where+instance Core.Context a s => HasType a s where+ typed = VL.ravel Core.derived+ {-# INLINE typed #-} - typed = ravel (repLens . gtyped)+-- |Every type 'has' itself.+instance {-# OVERLAPPING #-} HasType a a where+ getTyped = id+ {-# INLINE getTyped #-} --- See Note [Uncluttering type signatures]+ 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--type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constraint where- ErrorUnlessOne a s ('TypeStat '[_] '[] '[])- = TypeError- ( 'Text "The type "- ':<>: 'ShowType s- ':<>: 'Text " does not contain a value of type "- ':<>: 'ShowType a- )-- ErrorUnlessOne a s ('TypeStat (n ': ns) _ _)- = TypeError- ( 'Text "Not all constructors of the type "- ':<>: 'ShowType s- ':<>: 'Text " contain a field of type "- ':<>: 'ShowType a ':<>: 'Text "."- ':$$: 'Text "The offending constructors are:"- ':$$: ShowSymbols (n ': ns)- )-- ErrorUnlessOne a s ('TypeStat _ (m ': ms) _)- = TypeError- ( 'Text "The type "- ':<>: 'ShowType s- ':<>: 'Text " contains multiple values of type "- ':<>: 'ShowType a ':<>: 'Text "."- ':$$: 'Text "The choice of value is thus ambiguous. The offending constructors are:"- ':$$: ShowSymbols (m ': ms)- )-- ErrorUnlessOne _ _ ('TypeStat '[] '[] _)- = ()
+ src/Data/Generics/Product/Types.hs view
@@ -0,0 +1,112 @@+{-# 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 <kiss.csongor.kiss@gmail.com>+-- 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 #-}
src/Data/Generics/Sum.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE PackageImports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum--- Copyright : (C) 2017 Csongor Kiss+-- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability : experimental@@ -23,7 +24,7 @@ , module Data.Generics.Sum.Typed ) where -import Data.Generics.Sum.Any-import Data.Generics.Sum.Constructors-import Data.Generics.Sum.Subtype-import Data.Generics.Sum.Typed+import "this" Data.Generics.Sum.Any+import "this" Data.Generics.Sum.Constructors+import "this" Data.Generics.Sum.Subtype+import "this" Data.Generics.Sum.Typed
src/Data/Generics/Sum/Any.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}@@ -11,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Any--- Copyright : (C) 2017 Csongor Kiss+-- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability : experimental@@ -28,9 +29,9 @@ AsAny (..) ) where -import Data.Generics.Internal.Lens-import Data.Generics.Sum.Constructors-import Data.Generics.Sum.Typed+import "this" Data.Generics.Internal.VL.Prism+import "this" Data.Generics.Sum.Constructors+import "this" Data.Generics.Sum.Typed -- $setup -- == /Running example:/@@ -39,7 +40,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> import Control.Lens -- >>> :{ -- data Animal -- = Dog Dog@@ -61,7 +62,7 @@ -- :} -- |Sums that have generic prisms.-class AsAny (sel :: k) a s | s sel k -> a where+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.@@ -86,7 +87,7 @@ -- -- >>> duck ^? _As @Age -- Just 2- _As :: Prism' s a+ _As :: Prism s s a a instance AsConstructor ctor s s a a => AsAny ctor a s where _As = _Ctor @ctor
src/Data/Generics/Sum/Constructors.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}@@ -10,11 +10,12 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Constructors--- Copyright : (C) 2017 Csongor Kiss+-- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability : experimental@@ -29,17 +30,19 @@ -- $setup AsConstructor (..)+ , AsConstructor_ (..)+ , AsConstructor' (..)+ , AsConstructor0 (..) ) where -import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens-import Data.Generics.Internal.Void-import Data.Generics.Sum.Internal.Constructors+import "this" Data.Generics.Internal.VL.Prism -import Data.Kind (Constraint, Type)-import GHC.Generics (Generic (Rep))-import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))+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:/ --@@ -49,7 +52,7 @@ -- >>> :set -XFlexibleContexts -- >>> :set -XTypeFamilies -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> import Control.Lens -- >>> :m +Data.Generics.Product.Fields -- >>> :m +Data.Function -- >>> :{@@ -64,7 +67,7 @@ -- , age :: Age -- , fieldA :: a -- }--- deriving (Generic, Show)+-- deriving Show -- type Name = String -- type Age = Int -- dog, cat, duck :: Animal Int@@ -99,41 +102,50 @@ -- ... _Ctor :: Prism s t a b -instance- ( Generic s- , ErrorUnless ctor s (HasCtorP ctor (Rep s))- , Generic t- -- see Note [CPP in instance constraints]-#if __GLASGOW_HASKELL__ < 802- , '(s', t') ~ '(Proxied s, Proxied t)-#else- , s' ~ Proxied s- , t' ~ Proxied t-#endif- , Generic s'- , Generic t'- , GAsConstructor' ctor (Rep s) a- , GAsConstructor' ctor (Rep s') a'- , GAsConstructor ctor (Rep s) (Rep t) a b- , t ~ Infer s a' b- , GAsConstructor' ctor (Rep t') b'- , s ~ Infer t b' a- ) => AsConstructor ctor s t a b where+-- |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 - _Ctor = repIso . _GCtor @ctor+class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where+ _Ctor' :: Prism s s a a --- See Note [Uncluttering type signatures]+-- |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 -type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where- ErrorUnless ctor s 'False- = TypeError- ( 'Text "The type "- ':<>: 'ShowType s- ':<>: 'Text " does not contain a constructor named "- ':<>: 'ShowType ctor- )+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_ #-} - ErrorUnless _ _ 'True- = ()+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 #-}+
− src/Data/Generics/Sum/Internal/Constructors.hs
@@ -1,68 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Generics.Sum.Internal.Constructors--- Copyright : (C) 2017 Csongor Kiss--- License : BSD3--- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability : experimental--- Portability : non-portable------ Derive constructor-name-based prisms generically.-----------------------------------------------------------------------------------module Data.Generics.Sum.Internal.Constructors- ( GAsConstructor (..)- , GAsConstructor'- ) where--import Data.Generics.Internal.Families-import Data.Generics.Internal.HList-import Data.Generics.Internal.Lens--import GHC.Generics-import GHC.TypeLits (Symbol)---- |As 'AsConstructor' but over generic representations as defined by--- "GHC.Generics".-class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where- _GCtor :: Prism (s x) (t x) a b--type GAsConstructor' ctor s a = GAsConstructor ctor s s a a--instance- ( GCollectible f as- , GCollectible g bs- , ListTuple a as- , ListTuple b bs- ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where-- _GCtor = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)--instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where- _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)--instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where- _GCtor = mIso . _GCtor @ctor--class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where- _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b--instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where- _GSumCtor = left . _GCtor @ctor--instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where- _GSumCtor = right . _GCtor @ctor
− src/Data/Generics/Sum/Internal/Subtype.hs
@@ -1,74 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Generics.Sum.Internal.Subtype--- Copyright : (C) 2017 Csongor Kiss--- License : BSD3--- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability : experimental--- Portability : non-portable------ Structural subtype relationships between sum types.-----------------------------------------------------------------------------------module Data.Generics.Sum.Internal.Subtype- ( GAsSubtype (..)- ) where--import Data.Generics.Internal.HList-import Data.Generics.Sum.Internal.Typed--import Data.Kind-import GHC.Generics---- |As 'AsSubtype' but over generic representations as defined by--- "GHC.Generics".-class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where- ginjectSub :: subf x -> supf x- gprojectSub :: supf x -> Either (supf x) (subf x)--instance- ( GAsSubtype l supf- , GAsSubtype r supf- ) => GAsSubtype (l :+: r) supf where-- ginjectSub x = case x of- L1 l -> ginjectSub l- R1 r -> ginjectSub r- gprojectSub x- = case gprojectSub x of- Left _ -> fmap R1 (gprojectSub x)- Right y -> Right (L1 y)--instance- ( GAsType supf a- , GCollectible subf as- , ListTuple a as- ) => GAsSubtype (C1 meta subf) supf where-- ginjectSub- = ginjectTyped . listToTuple . gtoCollection . unM1- gprojectSub- = fmap (M1 . gfromCollection . tupleToList) . gprojectTyped--instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where- ginjectSub- = ginjectTyped @supf . unK1 . unM1- gprojectSub- = fmap (M1 . K1) . gprojectTyped @supf--instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where- ginjectSub- = ginjectSub . unM1- gprojectSub- = fmap M1 . gprojectSub
− src/Data/Generics/Sum/Internal/Typed.hs
@@ -1,88 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Generics.Sum.Internal.Typed--- Copyright : (C) 2017 Csongor Kiss--- License : BSD3--- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability : experimental--- Portability : non-portable------ Derive constructor-field-type-based prisms generically.-----------------------------------------------------------------------------------module Data.Generics.Sum.Internal.Typed- ( GAsType (..)- ) where--import Data.Kind-import GHC.Generics--import Data.Generics.Internal.Families-import Data.Generics.Internal.HList-import Data.Generics.Internal.Lens---- |As 'AsType' but over generic representations as defined by "GHC.Generics".-class GAsType (f :: Type -> Type) a where- _GTyped :: Prism' (f x) a- _GTyped = prism ginjectTyped gprojectTyped-- ginjectTyped :: a -> f x- gprojectTyped :: f x -> Either (f x) a--instance- ( GCollectible f as- , ListTuple a as- ) => GAsType (M1 C meta f) a where-- ginjectTyped- = M1 . gfromCollection . tupleToList- gprojectTyped- = Right . listToTuple . gtoCollection . unM1--instance GSumAsType (HasPartialTypeTupleP a l) l r a => GAsType (l :+: r) a where- ginjectTyped- = ginjectSumTyped @(HasPartialTypeTupleP a l) @l @r @a- gprojectTyped- = gprojectSumTyped @(HasPartialTypeTupleP a l) @l @r @a--instance GAsType f a => GAsType (M1 D meta f) a where- ginjectTyped- = M1 . ginjectTyped- gprojectTyped- = either (Left . M1) Right . gprojectTyped . unM1--class GSumAsType (contains :: Bool) l r a where- _GSumTyped :: Prism' ((l :+: r) x) a- _GSumTyped = prism (ginjectSumTyped @contains) (gprojectSumTyped @contains)-- ginjectSumTyped :: a -> (l :+: r) x- gprojectSumTyped :: (l :+: r) x -> Either ((l :+: r) x) a--instance GAsType l a => GSumAsType 'True l r a where- ginjectSumTyped- = L1 . ginjectTyped- gprojectSumTyped x- = case x of- L1 l -> either (Left . L1) Right (gprojectTyped l)- R1 _ -> Left x--instance GAsType r a => GSumAsType 'False l r a where- ginjectSumTyped- = R1 . ginjectTyped- gprojectSumTyped x- = case x of- R1 r -> either (Left . R1) Right (gprojectTyped r)- L1 _ -> Left x
src/Data/Generics/Sum/Subtype.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}@@ -9,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Subtype--- Copyright : (C) 2017 Csongor Kiss+-- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability : experimental@@ -26,12 +29,12 @@ AsSubtype (..) ) where -import Data.Generics.Internal.Lens-import Data.Generics.Internal.Void-import Data.Generics.Sum.Internal.Subtype+import "this" Data.Generics.Internal.VL.Prism -import GHC.Generics (Generic (Rep, to, from))+import "generic-lens-core" Data.Generics.Internal.Void+import qualified "generic-lens-core" Data.Generics.Sum.Internal.Subtype as Core + -- $setup -- == /Running example:/ --@@ -39,7 +42,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> import Control.Lens -- >>> :{ -- data Animal -- = Dog Dog@@ -86,29 +89,49 @@ -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal -- Nothing _Sub :: Prism' sup sub- _Sub = prism injectSub projectSub+ _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 -> Either sup sub+ projectSub :: sup -> Maybe sub+ projectSub+ = either (const Nothing) Just . match (_Sub @sub @sup) - {-# MINIMAL injectSub, projectSub #-}+ {-# MINIMAL (injectSub, projectSub) | _Sub #-} -instance- ( Generic sub- , Generic sup- , GAsSubtype (Rep sub) (Rep sup)- ) => AsSubtype sub sup where+instance Core.Context sub sup => AsSubtype sub sup where+ _Sub f = prism2prismvl Core.derived f+ {-# INLINE _Sub #-} - injectSub = to . ginjectSub . from- projectSub = either (Left . to) (Right . to) . gprojectSub . from+-- | Reflexive case+--+-- >>> _Sub # dog :: Animal+-- Dog (MkDog {name = "Shep", age = 3})+instance {-# OVERLAPPING #-} AsSubtype a a where+ _Sub = id+ {-# INLINE _Sub #-} --- See Note [Uncluttering type signatures]+-- | 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
src/Data/Generics/Sum/Typed.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -12,7 +14,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Typed--- Copyright : (C) 2017 Csongor Kiss+-- Copyright : (C) 2020 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability : experimental@@ -25,25 +27,21 @@ module Data.Generics.Sum.Typed ( -- *Prisms --- -- $setup+ -- $setup AsType (..) ) where -import Data.Kind-import GHC.Generics-import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)-import Data.Generics.Sum.Internal.Typed+import "this" Data.Generics.Internal.VL.Prism -import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens-import Data.Generics.Internal.Void+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--- >>> :m +Data.Generics.Internal.Lens+-- >>> import Control.Lens -- >>> :{ -- data Animal -- = Dog Dog@@ -63,10 +61,11 @@ -- 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.+-- |Types that can represent another type, either by being a sum with a+-- constructor containing that type, or by actually being that 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.@@ -84,54 +83,66 @@ -- ... Turtle -- ... _Typed :: Prism' s a+ _Typed = prism injectTyped (\i -> maybe (Left i) Right (projectTyped i))+ {-# INLINE _Typed #-} -- |Inject by type.+ --+ --+ -- >>> :{+ -- dog :: Dog+ -- dog = MkDog "Fido" (Age 11)+ -- dogAsAnimal :: Animal+ -- dogAsAnimal = injectTyped dog+ -- dogAsItself :: Dog+ -- dogAsItself = injectTyped dog+ -- >>> :} injectTyped :: a -> s+ injectTyped+ = build _Typed -- |Project by type.+ --+ --+ -- >>> :{+ -- dogAsAnimal :: Animal+ -- dogAsAnimal = Dog (MkDog "Fido" (Age 11))+ -- mDog :: Maybe Dog+ -- mDog = projectTyped dogAsAnimal+ -- >>> :} projectTyped :: s -> Maybe a+ projectTyped+ = either (const Nothing) Just . match _Typed -instance- ( Generic s- , ErrorUnlessOne a s (CollectPartialType a (Rep s))- , GAsType (Rep s) a- ) => AsType a s where+ {-# MINIMAL (injectTyped, projectTyped) | _Typed #-} - _Typed- = repIso . _GTyped- injectTyped- = to . ginjectTyped- projectTyped- = either (const Nothing) Just . gprojectTyped . from+-- |Every type can be treated 'as' itself.+instance {-# OVERLAPPING #-} AsType a a where+ injectTyped = id+ projectTyped = Just --- See Note [Uncluttering type signatures]+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 -type family ErrorUnlessOne (a :: Type) (s :: Type) (ctors :: [Symbol]) :: Constraint where- ErrorUnlessOne _ _ '[_]- = ()-- ErrorUnlessOne a s '[]- = TypeError- ( 'Text "The type "- ':<>: 'ShowType s- ':<>: 'Text " does not contain a constructor whose field is of type "- ':<>: 'ShowType a- )-- ErrorUnlessOne a s cs- = TypeError- ( 'Text "The type "- ':<>: 'ShowType s- ':<>: 'Text " contains multiple constructors whose fields are of type "- ':<>: 'ShowType a ':<>: 'Text "."- ':$$: 'Text "The choice of constructor is thus ambiguous, could be any of:"- ':$$: ShowSymbols cs- )
+ src/Data/Generics/Wrapped.hs view
@@ -0,0 +1,73 @@+{-# 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 <kiss.csongor.kiss@gmail.com>+-- 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 #-}
− test/24.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}--module Main 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
− test/25.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# OPTIONS_GHC -Wall #-}--module Main 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)
+ test/Bifunctor.hs view
@@ -0,0 +1,47 @@+{-# 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
+ test/CustomChildren.hs view
@@ -0,0 +1,63 @@+{-# 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]
test/Spec.hs view
@@ -1,6 +1,10 @@ {-# 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 #-}@@ -9,15 +13,36 @@ {-# 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 Test146 ()++import CustomChildren (customTypesTest)+ main :: IO ()-main = putStrLn "Hello world"+main = do+ res <- runTestTT tests+ case errors res + failures res of+ 0 -> exitSuccess+ _ -> exitFailure data Record = MkRecord { fieldA :: Int@@ -33,11 +58,19 @@ , fieldB :: Bool } deriving (Generic, Show) -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+data Record4 a = MkRecord4+ { fieldA :: a+ , fieldB :: a+ } deriving (Generic1) -fieldALensManual :: Lens' Record Int-fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a+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@@ -47,12 +80,103 @@ 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@@ -63,28 +187,102 @@ 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 = field @"fieldA"+typeChangingGeneric = #fieldA typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b typeChangingGenericPos = position @1 typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b-typeChangingGenericCompose = field @"fieldA" . field @"fieldA"+typeChangingGenericCompose = #fieldA . #fieldA -inspect $ 'fieldALensManual === 'fieldALensName-inspect $ 'fieldALensManual === 'fieldALensType-inspect $ 'fieldALensManual === 'fieldALensPos-inspect $ 'subtypeLensManual === 'subtypeLensGeneric-inspect $ 'typeChangingManual === 'typeChangingGeneric-inspect $ 'typeChangingManual === 'typeChangingGenericPos-inspect $ 'typeChangingManualCompose === 'typeChangingGenericCompose+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) -- TODO fails >=9.12+ , $(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++ , (valLabel ^. #1 ) ~=? 3+ , let+ i x = x :: Int+ largeTuple = (i 1, i 2, i 3, i 4, i 5, i 6, i 7, i 8, i 9, i 10, i 11, i 12, i 13, i 14, i 15)+ largeTuple' = (i 1, i 2, i 3, i 4, i 5, i 6, i 7, i 8, i 9, i 10, i 11, i 13, i 13, i 14, i 15)+ in+ (largeTuple ^. #13, largeTuple & #12 +~ 1) ~=? (13, largeTuple')+#endif+ , customTypesTest+ ]+ where valLabel = RecB 3 True++-- TODO: add test for traversals over multiple types
+ test/Test146.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}++module Test146 where++import Control.Monad.Except+import Data.Generics.Sum+import GHC.Generics++data Error = Error+ deriving (Generic)++poly :: (AsType Error e, MonadError e m) => m ()+poly = undefined++mono :: ExceptT Error IO ()+mono = poly
+ test/Test24.hs view
@@ -0,0 +1,47 @@+{-# 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
+ test/Test25.hs view
@@ -0,0 +1,33 @@+{-# 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)
+ test/Test40.hs view
@@ -0,0 +1,22 @@+{-# 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)
+ test/Test62.hs view
@@ -0,0 +1,20 @@+{-# 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 = () } }
+ test/Test63.hs view
@@ -0,0 +1,12 @@+{-# 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)
+ test/Test88.hs view
@@ -0,0 +1,17 @@+{-# 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
+ test/Util.hs view
@@ -0,0 +1,11 @@+module 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+
− test/doctest.hs
@@ -1,7 +0,0 @@-import Test.DocTest-main- = doctest- [ "-isrc"- , "src/Data/Generics/Product.hs"- , "src/Data/Generics/Sum.hs"- ]
+ test/syb/Tree.hs view
@@ -0,0 +1,76 @@+{-# 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 _ = []