generic-lens 0.5.1.0 → 1.0.0.0

raw patch · 54 files changed

+2901/−963 lines, 54 filesdep +HUnitdep +dump-coredep ~basedep ~criteriondep ~inspection-testingPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, dump-core

Dependency ranges changed: base, criterion, inspection-testing, profunctors

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• README.md +235/−78
• examples/Biscuits.hs +150/−0
• examples/Examples.hs +6/−1
• examples/doctest.hs +6/−0
• generic-lens.cabal +72/−15
• src/Data/Generics/Internal/Families.hs +1/−1
• src/Data/Generics/Internal/Families/Changing.hs +41/−32
• src/Data/Generics/Internal/Families/Collect.hs +3/−2
• src/Data/Generics/Internal/Families/Has.hs +21/−34
• src/Data/Generics/Internal/GenericN.hs +74/−0
• src/Data/Generics/Internal/HList.hs +0/−239
• src/Data/Generics/Internal/Lens.hs +0/−143
• src/Data/Generics/Internal/Profunctor/Iso.hs +103/−0
• src/Data/Generics/Internal/Profunctor/Lens.hs +170/−0
• src/Data/Generics/Internal/Profunctor/Prism.hs +118/−0
• src/Data/Generics/Internal/VL/Iso.hs +52/−0
• src/Data/Generics/Internal/VL/Lens.hs +65/−0
• src/Data/Generics/Internal/VL/Prism.hs +73/−0
• src/Data/Generics/Internal/VL/Traversal.hs +91/−0
• src/Data/Generics/Internal/Void.hs +1/−0
• src/Data/Generics/Product.hs +9/−0
• src/Data/Generics/Product/Any.hs +2/−2
• src/Data/Generics/Product/Constraints.hs +57/−0
• src/Data/Generics/Product/Fields.hs +24/−16
• src/Data/Generics/Product/Internal/Constraints.hs +141/−0
• src/Data/Generics/Product/Internal/Fields.hs +0/−77
• src/Data/Generics/Product/Internal/Keyed.hs +60/−0
• src/Data/Generics/Product/Internal/List.hs +335/−0
• src/Data/Generics/Product/Internal/Positions.hs +17/−24
• src/Data/Generics/Product/Internal/Subtype.hs +6/−6
• src/Data/Generics/Product/Internal/Typed.hs +0/−62
• src/Data/Generics/Product/List.hs +78/−0
• src/Data/Generics/Product/Param.hs +114/−0
• src/Data/Generics/Product/Positions.hs +21/−10
• src/Data/Generics/Product/Subtype.hs +7/−6
• src/Data/Generics/Product/Typed.hs +12/−10
• src/Data/Generics/Product/Types.hs +163/−0
• src/Data/Generics/Sum/Any.hs +3/−3
• src/Data/Generics/Sum/Constructors.hs +19/−3
• src/Data/Generics/Sum/Internal/Constructors.hs +14/−5
• src/Data/Generics/Sum/Internal/Subtype.hs +65/−31
• src/Data/Generics/Sum/Internal/Typed.hs +32/−53
• src/Data/Generics/Sum/Subtype.hs +15/−8
• src/Data/Generics/Sum/Typed.hs +19/−10
• test/24.hs +0/−47
• test/25.hs +0/−33
• test/Bifunctor.hs +47/−0
• test/Spec.hs +162/−12
• test/Test24.hs +47/−0
• test/Test25.hs +33/−0
• test/Test40.hs +22/−0
• test/Util.hs +11/−0
• test/syb/Tree.hs +76/−0

@@ -1,3 +1,11 @@+## 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)+ ## 0.5.1.0 - Infer input type from result type (#25) - Allow changing of multiple type parameters (#24)

@@ -3,26 +3,66 @@ [![Build Status](https://travis-ci.org/kcsongor/generic-lens.svg?branch=master)](https://travis-ci.org/kcsongor/generic-lens) [![Hackage](https://img.shields.io/hackage/v/generic-lens.svg)](https://hackage.haskell.org/package/generic-lens) -Generically derive lenses and prisms for data types.+Generically derive traversals, lenses and prisms.  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 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. -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).+The derived optics use the so-called van Laarhoven representation, thus are+fully interoperable with the combinators found in mainstream lens libraries. -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).+Examples can be found in the `examples` and `tests` folders. +Table of contents+=================++* [Preliminaries](#preliminaries)+* [Taxonomy of optics](#taxonomy-of-optics)+   * [Lenses](#lenses)+      * [By name](#by-name)+      * [By position](#by-position)+      * [By type](#by-type)+      * [By structure](#by-structure)+   * [Traversals](#traversals)+      * [By type](#by-type-1)+      * [By parameter](#by-parameter)+      * [By constraint](#by-constraint)+   * [Prisms](#prisms)+      * [By name](#by-name-1)+      * [By type](#by-type-2)+* [Performance](#performance)+  * [Inspection testing](#inspection-testing)+  * [Benchmarks](#benchmarks)+* [Contributors](#contributors)++# Preliminaries+A typical module using `generic-lens` will usually have the following+extensions turned on:+```haskell+{-# LANGUAGE AllowAmbiguousTypes       #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE DuplicateRecordFields     #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeApplications          #-}++```++# Taxonomy of optics+Here is a comprehensive list of the optics exposed by `generic-lens`. The+combinators each allow a different way of identifying certain parts of+algebraic data types.+ ## Lenses -### Record fields+A lens identifies exactly one part of a product type, and allows querying and+updating it. -Record fields can be accessed by their label:+### By name  ```haskell data Person = Person { name :: String, age :: Int } deriving (Generic, Show)@@ -31,43 +71,84 @@ sally = Person "Sally" 25 ``` -```haskell->>> getField @"age" sally-25-->>> setField @"age" 26 sally-Person {name = "Sally", age = 26}+Record fields can be accessed by their label using the `field` lens. +```haskell >>> sally ^. field @"name" "Sally"  >>> sally & field @"name" .~ "Tamas" Person {name = "Tamas", age = 25}+```+Here we use [visible type application](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#visible-type-application)+to specify which field we're interested in, and use the `^.` and `.~` combinators from a lens library+([lens](https://hackage.haskell.org/package/lens), [microlens](https://hackage.haskell.org/package/microlens), etc.)+to query and update the field. +Or for standalone use, the `getField` and `setField` functions can be used instead.+```haskell+>>> getField @"age" sally+25++>>> setField @"age" 26 sally+Person {name = "Sally", age = 26}+```++When a non-existent field is requested, the library generates a helpful type error:+```haskell >>> sally ^. field @"pet" error:-  • The type Person does not contain a field named "pet"+  • 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:+For types with multiple constructors, we can still use `field` as long as all constructors contain the required field+```haskell+data Two+ = First  { wurble :: String, banana :: Int }+ | Second { wurble :: String }+ deriving (Generic, Show) +>>> Second "woops" ^. field @"wurble"+"woops"+>>> Second "woops" ^. field @"banana"+    ...+    • Not all constructors of the type Two+       contain a field named 'banana'.+      The offending constructors are:+      • Second+    ...+```++The type of `field` is ```haskell-data T a b c d = T-  { paramA :: a-  , paramB :: b-  , paramC :: c-  , paramD :: d-  }-  deriving (Generic, Show)+field :: HasField name s t a b => Lens s t a b+```+Therefore it allows polymorphic (type-changing) updates, when the accessed field mentions type parameters. ->>> t = T "a" (10 :: Int) 'c' False->>> t & field @"paramA" .~ 'a' & field @"paramB" .~ False-T {paramA = 'a', paramB = False, paramC = 'c', paramD = False}+```haskell+data Foo f a = Foo+  { foo :: f a+  } deriving (Generic, Show)++foo1 :: Foo Maybe Int+foo1 = Foo (Just 10)++-- |+-- >>> foo2+-- Foo {foo = ["10"]}+foo2 :: Foo [] String+foo2 = foo1 & field @"foo" %~ (maybeToList . fmap show) ```+This example shows that higher-kinded parameters can also be changed (`Maybe`+-> `[]`). We turn a `Foo Maybe Int` into a `Foo [] String` by turning the inner+`Maybe Int` into a `[String]`. -### Positional fields+With `DuplicateRecordFields`, multiple data types can share the same field+name, and the `field` lens works in this case too. No more field name+prefixing! +### By position+ Fields can be accessed by their position in the data structure (index starting at 1):  ```haskell@@ -79,12 +160,6 @@ ```  ```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 @@ -96,49 +171,34 @@   • The type Polygon does not contain a field at position 10 ``` -Since tuples are an instance of `Generic`, they also have positional lenses:+Since tuples are an instance of `Generic`, the positional lens readily works:  ```haskell >>> (("hello", True), 5) ^. position @1 . position @2 True+>>> (("hello", True, "or"), 5, "even", "longer") ^. position @1 . position @2+True ``` -### Typed fields+### By type  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 ^. typed @String "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+### By structure -A record is a (structural) `subtype' of another, if its fields are a superset of-those of the other.+The `super` lens generalises the `field` lens to focus on a collection rather+than a single field.+We can say that a record is a (structural) `subtype' of another, if its fields+are a superset of those of the other.  ```haskell data Human = Human@@ -157,16 +217,10 @@ ```  ```haskell-->>> upcast human :: Animal+>>> human ^. super @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+>>> upcast human :: Animal Animal {name = "Tunyasz", age = 50} ``` @@ -181,10 +235,97 @@ Human {name = "Tunyasz", age = 60, address = "London"} ``` +## Traversals++Traversals allow multiple values to be queried or updated at the same time.++As a running example, consider a data type of weighted trees. There are two+type parameters, which correspond to the type of elements and weights in the+tree:+```haskell+data WTree a w+  = Leaf a+  | Fork (WTree a w) (WTree a w)+  | WithWeight (WTree a w) w+  deriving (Generic, Show)++mytree :: WTree Int Int+mytree = Fork (WithWeight (Leaf 42) 1)+              (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)+```++### By type+Focus on all values of a given type.++```haskell+types :: HasTypes s a => Traversal' s a+```++```haskell+>>> toListOf (types @Int) myTree+[42,1,88,37,2]+```++Note that this traversal is "deep": the subtrees are recursively traversed.++### By parameter+As the above example shows, the `types` traversal is limited in that it cannot+distinguish between the two types of `Int`s: the weights and the values.++Instead, the `param` traversal allows specifying types that correspond to a+certain type parameter.+```haskell+param :: HasParam pos s t a b => Traversal s t a b+```++```haskell+>>> toListOf (param @1) myTree+[42,88,37]+```++Here, the numbering starts from 0, with 0 being the rightmost parameter.+Because `param` is guaranteed to focus on parametric values, it allows the type+to be changed as well.++For example, we can implement `Functor` for `WTree` as simply as:++```haskell+instance Functor (WTree a) where+  fmap = over (param @0)+```++### By constraint+The most general type of traversal: we can apply a given function to every+value in a structure, by requiring that all values have an instance for some+type class.++```haskell+constraints   :: HasConstraints c s t => Applicative g => (forall a b . c a b => a -> g b) -> s -> g t+constraints'  :: HasConstraints' c s  => Applicative g => (forall a . c a => a -> g a) -> s -> g s+```++Consider the `Numbers` type, which contains three different numeric types:+```haskell+data Numbers = Numbers Int Float Double+  deriving (Show, Generic)++numbers = Numbers 10 20.0 30.0+```++With `constraints'`, we can uniformly add 20 to each number in one go:+```haskell+>>> constraints' @Num (\x -> pure (x + 20)) numbers+Numbers 30 40.0 50.0+```+ ## Prisms -### Named constructors+A prism focuses on one part of a sum type (which might not be present). Other+than querying the type, they can be "turned around" to inject the data into the+sum (like a constructor). +### By name+ Constructor components can be accessed using the constructor's name:  ```haskell@@ -205,19 +346,20 @@  >>> shep ^? _Ctor @"Cat" Nothing+``` +Constructors with multiple fields can be focused as a tuple++``` >>> 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+### By type  Constructor components can be accessed using the component's type, assuming that this type is unique:@@ -227,10 +369,10 @@ 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)+data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show)  shep = Dog (MkDog "Shep" 4)-mog = Cat ("Mog", 5)+mog = Cat "Mog" 5 donald = Duck 4 ``` @@ -244,6 +386,9 @@ >>> donald ^? _Typed @Age Just 4 +>>> mog ^? _Typed @(Name, Age)+("Mog", 5)+ >>> donald ^? _Typed @Float error:   • The type Animal does not contain a constructor whose field is of type Float@@ -252,7 +397,19 @@ Duck 6 ``` -## Contributors+# Performance+The runtime characteristics of the derived optics is in most cases identical at+`-O1`, in some cases only slightly slower than the hand-written version. This+is thanks to GHC's optimiser eliminating the generic overhead. +The+[inspection-testing](https://hackage.haskell.org/package/inspection-testing)+library is used to ensure (see [here](test/Spec.hs)) that everything gets+inlined away.++TODO push benchmarks too+# Contributors+++ [Matthew Pickering](https://github.com/mpickering) + [Toby Shaw](https://github.com/TobyShaw) + [Will Jones](https://github.com/lunaris)

@@ -0,0 +1,150 @@+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE DuplicateRecordFields     #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeApplications          #-}++module Main where++import Control.Lens+import           Data.Maybe (maybeToList)+import Data.Generics.Product+import Data.Generics.Sum+import GHC.Generics (Generic)++-- $setup+--+-- >>> :set -XTypeApplications+-- >>> :set -XDataKinds+-- >>> :set -XFlexibleContexts++main :: IO ()+main = putStrLn "hello"++data Item = Item+ { name :: String+ , cost :: Cost+ } deriving (Generic, Show)++newtype Cost = Cost Double deriving (Generic, Show)++data Invoice p = Invoice+ { item :: Item+ , name :: String+ , number :: Int+ , priority :: p+ } deriving (Generic, Show)++data Orders = Orders [ Invoice Int ] [ Invoice (Int, Double) ]+  deriving (Generic, Show)++-- |+-- >>> view (field @"name") bourbon+-- "Bourbon"+-- >>> bourbon & field @"cost" .~ Cost 110+-- Item {name = "Bourbon", cost = Cost 110.0}+--+-- >>> bourbon & field @"cost" %~ (\(Cost c) -> (Cost (c + 5)))+-- Item {name = "Bourbon", cost = Cost 105.0}+--+-- >>> Invoice bourbon "Johnny" 2 2 & field @"priority" %~ (\i -> (i, 0))+-- Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "Johnny", number = 2, priority = (2,0)}+--+-- >>> view (field @"weight") bourbon+-- ...+-- ... The type Item does not contain a field named 'weight'.+-- ...+--+-- >>> bourbon & typed @Cost .~ Cost 200+-- Item {name = "Bourbon", cost = Cost 200.0}+--+-- >>> bourbon & typed %~ ("Chocolate " ++)+-- Item {name = "Chocolate Bourbon", cost = Cost 100.0}+--+-- >>> view (position @1) (42, "foo")+-- 42+-- >>> view (position @1) (42, "foo", False)+-- 42+-- >>> view (position @2) orders+-- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}]+--+-- >>> view (position @2) orders+-- [Invoice {item = Item {name = "Bourbon", cost = Cost 100.0}, name = "George", number = 2, priority = (0,3.0)}]+--+-- >>> view (position @3) orders+-- ...+-- ... The type Orders does not contain a field at position 3+-- ...+--+-- >>> view (super @Item) (WItem "Bourbon" (Cost 2000) (Weight 0.03))+-- Item {name = "Bourbon", cost = Cost 2000.0}+--+-- >>> (WItem "Bourbon+" (Cost 500) (Weight 0.03)) & super @Item .~ bourbon+-- WItem {name = "Bourbon", cost = Cost 100.0, weight = Weight 3.0e-2}+--+-- >>> DInt 1 ^? _Ctor @"DInt"+-- Just 1+--+-- >>> _Typed # (False, "wurble") :: D+-- DPair False "wurble"+--+-- >>>  EChar 'a' ^? _Sub @D+-- Nothing+--+-- >>> _Sub  # DInt 10 :: E+-- EInt 10+bourbon :: Item+bourbon = Item "Bourbon" (Cost 100)++orders :: Orders+orders = Orders  [Invoice bourbon "Earl" 1 0 , Invoice bourbon "Johnny" 2 2]+                 [Invoice bourbon "George" 2 (0, 3)]++nameOfItem :: Invoice p -> String+nameOfItem = view (field @"item" . field @"name")++thankYou :: Orders -> Orders+thankYou = over (types @Cost) (\(Cost c) -> Cost (c * 0.85))++thankYouPriority :: Orders -> Orders+thankYouPriority = over (position @2 . types @Cost) (\(Cost c) -> Cost (c * 0.85))++upgrade :: Double -> Invoice Int -> Invoice (Int, Double)+upgrade bribe invoice = over (param @0) (\i -> (i, bribe)) invoice++audit :: Orders -> [Item]+audit = toListOf (types @Item)++newtype Weight = Weight Double deriving (Generic, Show)+data WeighedItem = WItem+ { name :: String+ , cost :: Cost+ , weight :: Weight+ } deriving (Generic, Show)++data D = DInt Int | DPair Bool String+  deriving (Generic, Show)++data E = EInt Int | EPair Bool String | EChar Char+  deriving (Generic, Show)++costInc :: HasTypes t Cost => t -> t+costInc = over (types @Cost) (\(Cost c) -> Cost (c + 5))++modifyPriority :: (Int -> Int) -> Invoice Int -> Invoice Int+modifyPriority = over (types @Int)++treeIncParam :: HasParam 0 s s Int Int => s -> s+treeIncParam = over (param @0) (+ 1)++instance Functor Invoice where+  fmap = over (param @0)++data Numbers = Numbers Int Float Double+  deriving (Show, Generic)++-- |+-- >>> constraints' @Num (\x -> pure (x + 20)) numbers+-- Numbers 30 40.0 50.0+numbers = Numbers 10 20.0 30.0

@@ -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

@@ -0,0 +1,6 @@+import Test.DocTest+main+  = doctest+      [ "-iexamples"+      , "examples/Biscuits.hs"+      ]

@@ -1,7 +1,7 @@ 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:              1.0.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.  homepage:             https://github.com/kcsongor/generic-lens license:              BSD3@@ -18,38 +18,53 @@                     , examples/Examples.hs                     , README.md +flag dump-core+  description: Dump HTML for the core generated by GHC during compilation+  default:     False+ library   exposed-modules:    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.Constraints+                    , Data.Generics.Product.List+                    , Data.Generics.Internal.GenericN                      , Data.Generics.Sum                     , Data.Generics.Sum.Any                     , Data.Generics.Sum.Constructors                     , Data.Generics.Sum.Typed                     , Data.Generics.Sum.Subtype-                    , Data.Generics.Internal.Lens+                    , Data.Generics.Internal.Profunctor.Lens+                    , Data.Generics.Internal.Profunctor.Prism+                    , Data.Generics.Internal.Profunctor.Iso+                    , Data.Generics.Internal.VL.Lens+                    , Data.Generics.Internal.VL.Traversal+                    , Data.Generics.Internal.VL.Prism+                    , Data.Generics.Internal.VL.Iso    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.Product.Internal.Constraints+                    , Data.Generics.Product.Internal.List+                    , Data.Generics.Product.Internal.Keyed+   build-depends:      base        >= 4.9 && <= 5.0                     , profunctors >= 5.0 && <= 6.0                     , tagged      >= 0.8 && <= 0.9@@ -57,46 +72,79 @@   hs-source-dirs:     src   default-language:   Haskell2010   ghc-options:        -Wall+  if flag(dump-core)+    build-depends: dump-core+    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html  source-repository head   type:               git   location:           https://github.com/kcsongor/generic-lens +test-suite generic-lens-examples+  type:               exitcode-stdio-1.0+  hs-source-dirs:     examples+  main-is:            Biscuits.hs+  --other-modules:++  build-depends:      base          >= 4.9 && <= 5.0+                    , generic-lens+                    , lens+                    , profunctors+                    , HUnit++  default-language:   Haskell2010+ test-suite generic-lens-test   type:               exitcode-stdio-1.0   hs-source-dirs:     test   main-is:            Spec.hs+  other-modules:      Util Test24 Test25 Test40    build-depends:      base          >= 4.9 && <= 5.0                     , generic-lens-                    , inspection-testing >= 0.1+                    , lens+                    , profunctors+                    , inspection-testing >= 0.2+                    , HUnit    default-language:   Haskell2010   ghc-options:        -Wall+  if flag(dump-core)+    build-depends: dump-core+    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html -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                     , generic-lens                     , lens+                    , HUnit    default-language:   Haskell2010   ghc-options:        -Wall+  if flag(dump-core)+    build-depends: dump-core+    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html -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                     , generic-lens                     , lens+                    , profunctors+                    , HUnit    default-language:   Haskell2010   ghc-options:        -Wall+  if flag(dump-core)+    build-depends: dump-core+    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html  test-suite doctests   default-language:   Haskell2010@@ -106,6 +154,14 @@   build-depends:      base >4 && <5, doctest   hs-source-dirs:     test +test-suite examples-doctests+  default-language:   Haskell2010+  type:               exitcode-stdio-1.0+  ghc-options:        -threaded+  main-is:            doctest.hs+  build-depends:      base >4 && <5, doctest+  hs-source-dirs:     examples+ benchmark generic-lens-bench   type:               exitcode-stdio-1.0   hs-source-dirs:     benchmarks@@ -115,9 +171,10 @@                      , base        >= 4.9 && <= 5.0                     , QuickCheck-                    , criterion+                    , criterion < 1.3.0.0 && >= 1.2.0.0                     , deepseq                     , lens    default-language:   Haskell2010   ghc-options:        -Wall+

@@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE KindSignatures        #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-} @@ -28,6 +27,7 @@  import GHC.TypeLits (ErrorMessage (..), Symbol) +-- * Stuff type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where   ShowSymbols '[]     = 'Text ""

@@ -11,10 +11,14 @@ module Data.Generics.Internal.Families.Changing   ( Proxied   , Infer+  , PTag (..)+  , P+  , LookupParam+  , ArgAt+  , ArgCount   ) where -import GHC.TypeLits (TypeError, ErrorMessage (..))-import Data.Type.Bool (If)+import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))  {-   Note [Changing type parameters]@@ -49,19 +53,20 @@ -- 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 family P :: Nat -> k -> PTag -> k -type Proxied t = Proxied' t 'Z+type Proxied t = Proxied' t 0 -type family Proxied' (t :: k) (next :: Peano) :: k where-  Proxied' (t (a :: j) :: k) next = (Proxied' t ('S next)) (P next a 'PTag)+type family Proxied' (t :: k) (next :: Nat) :: k where+  Proxied' (t (a :: j) :: k) next = (Proxied' t (next + 1)) (P next a 'PTag)   Proxied' t _ = t  data Sub where-  Sub :: Peano -> k -> Sub+  Sub :: Nat -> 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 (p n _ 'PTag) a' = '[ 'Sub n a']+  Unify (a x) (b y) = Unify x y ++ Unify a b   Unify a a = '[]   Unify a b = TypeError                 ( 'Text "Couldn't match type "@@ -70,23 +75,6 @@                   ':<>: '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)@@ -98,27 +86,48 @@  -------------------------------------------------------------------------------- -data Peano = Z | S Peano- -- [TODO]: work this out -----type family ArgKind (t :: k) (pos :: Peano) :: * where+--type family ArgKind (t :: k) (pos :: Nat) :: * 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+--type family ReplaceArg (t :: k) (pos :: Nat) (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+type family ReplaceArg (t :: k) (pos :: Nat) (to :: j) :: k where+  ReplaceArg (t a) 0 to = t to+  ReplaceArg (t a) pos to = ReplaceArg t (pos - 1) 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++type family LookupParam (a :: k) (p :: Nat) :: Maybe Nat where+  LookupParam (param (n :: Nat)) m = 'Nothing+  LookupParam (a (_ (m :: Nat))) n = IfEq m n ('Just 0) (MaybeAdd (LookupParam a n) 1)+  LookupParam (a _) n = MaybeAdd (LookupParam a n) 1+  LookupParam a _ = 'Nothing++type family MaybeAdd (a :: Maybe Nat) (b :: Nat) :: Maybe Nat where+  MaybeAdd 'Nothing _  = 'Nothing+  MaybeAdd ('Just a) b = 'Just (a + b)++type family IfEq (a :: k) (b :: k) (t :: l) (f :: l) :: l where+  IfEq a a t _ = t+  IfEq _ _ _ f = f++type family ArgCount (t :: k) :: Nat where+  ArgCount (f a) = 1 + ArgCount f+  ArgCount a = 0++type family ArgAt (t :: k) (n :: Nat) :: j where+  ArgAt (t a) 0 = a+  ArgAt (t a) n = ArgAt t (n - 1)+  -- Note [CPP in instance constraints] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -28,7 +28,8 @@ import GHC.Generics import GHC.TypeLits       (Symbol, CmpSymbol) -import Data.Generics.Internal.HList+import Data.Generics.Product.Internal.List (type (++))+import Data.Generics.Internal.Families.Has (GTypes)  data TypeStat   = TypeStat@@ -83,7 +84,7 @@   CollectPartialType t (l :+: r)     = CollectPartialType t l ++ CollectPartialType t r   CollectPartialType t (C1 ('MetaCons ctor _ _) f)-    = If (t == ListToTuple (GCollect f)) '[ctor] '[]+    = If (t == GTypes f) '[ctor] '[]   CollectPartialType t (D1 _ f)     = CollectPartialType t f 

@@ -16,9 +16,9 @@ ----------------------------------------------------------------------------- module Data.Generics.Internal.Families.Has   ( HasTotalFieldP-  , HasTotalTypeP-  , HasPartialTypeTupleP+  , HasPartialTypeP   , HasCtorP+  , GTypes   ) where  import Data.Type.Bool     (type (||), type (&&))@@ -26,7 +26,7 @@ import GHC.Generics import GHC.TypeLits       (Symbol, TypeError, ErrorMessage (..)) -import Data.Generics.Internal.HList+import Data.Generics.Product.Internal.List  type family HasTotalFieldP (field :: Symbol) f :: Bool where   HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)@@ -53,37 +53,14 @@         ':<>: '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 _+type family HasPartialTypeP a f :: Bool where+  HasPartialTypeP t (l :+: r)+    = HasPartialTypeP t l || HasPartialTypeP t r+  HasPartialTypeP t (C1 m f)+    = t == GTypes f+  HasPartialTypeP t (M1 _ _ f)+    = HasPartialTypeP t f+  HasPartialTypeP t _     = 'False  type family HasCtorP (ctor :: Symbol) f :: Bool where@@ -95,3 +72,13 @@     = HasCtorP ctor f   HasCtorP ctor _     = 'False++type family GTypes (rep :: * -> *) :: [((), *)] where+  GTypes (l :*: r)+    = GTypes l ++ GTypes r+  GTypes (Rec0 a)+    = '[ '( '(), a)]+  GTypes (M1 _ m a)+    = GTypes a+  GTypes U1 = '[]+

@@ -0,0 +1,74 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE InstanceSigs         #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++--------------------------------------------------------------------------------+-- |+-- Module      : Data.Generics.Internal.GenericN+-- Copyright   : (C) 2018 Csongor Kiss+-- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- License     : BSD3+-- Stability   : experimental+-- Portability : non-portable+--+-- Generic representation of types with multiple parameters+--+--------------------------------------------------------------------------------++module Data.Generics.Internal.GenericN+  ( Param+  , Rec (Rec, unRec)+  , GenericN (..)+  ) where++import Data.Kind+import GHC.Generics+import GHC.TypeLits+import Data.Coerce++type family Param :: Nat -> k where++type family Indexed (t :: k) (i :: Nat) :: k where+  Indexed (t a) i = Indexed t (i + 1) (Param i)+  Indexed t _     = t++newtype Rec (p :: Type) a x = Rec { unRec :: K1 R a x }++type family Zip (a :: Type -> Type) (b :: Type -> Type) :: Type -> Type where+  Zip (M1 mt m s) (M1 mt m t)+    = M1 mt m (Zip s t)+  Zip (l :+: r) (l' :+: r')+    = Zip l l' :+: Zip r r'+  Zip (l :*: r) (l' :*: r')+    = Zip l l' :*: Zip r r'+  Zip (Rec0 p) (Rec0 a)+    = Rec p a+  Zip U1 U1+    = U1++class+  ( Coercible (Rep a) (RepN a)+  , Generic a+  ) => GenericN (a :: Type) where+  type family RepN (a :: Type) :: Type -> Type+  type instance RepN a = Zip (Rep (Indexed a 0)) (Rep a)+  toN :: RepN a x -> a+  fromN :: a -> RepN a x++instance+  ( Coercible (Rep a) (RepN a)+  , Generic a+  ) => GenericN a where+  toN :: forall x. RepN a x -> a+  toN   = coerce (to :: Rep a x -> a)+  {-# INLINE toN #-}++  fromN :: forall x. a -> RepN a x+  fromN = coerce (from :: a -> Rep a x)+  {-# INLINE fromN #-}

@@ -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

@@ -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

@@ -0,0 +1,103 @@+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Rank2Types                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeFamilyDependencies    #-}+{-# LANGUAGE TypeOperators             #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Internal.Profunctor.Iso+-- 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.Profunctor.Iso where++import Data.Profunctor        (Profunctor(..))+import Data.Profunctor.Unsafe ((#.), (.#))+import GHC.Generics           ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)+import Data.Coerce+import Data.Generics.Internal.GenericN (Rec (..))++type Iso s t a b+  = forall p. (Profunctor p) => p a b -> p s t++type Iso' s a = Iso s s a a++-- | 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++-- | '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 = iso unM1 M1+{-# INLINE mIso #-}++kIso :: Iso (K1 r a p) (K1 r b p) a b+kIso = iso unK1 K1+{-# INLINE kIso #-}++recIso :: Iso (Rec r a p) (Rec r b p) a b+recIso = iso (unK1 . unRec) (Rec . K1)+{-# INLINE recIso #-}++sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))+sumIso = iso back forth+  where forth (Left l)  = L1 l+        forth (Right r) = R1 r+        back (L1 l) = Left l+        back (R1 r) = Right r+{-# INLINE sumIso #-}++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))++assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))+assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))++--------------------------------------------------------------------------------+-- Iso stuff++fromIso :: Iso s t a b -> Iso b a t s+fromIso l = withIso l $ \ sa bt -> iso bt sa+{-# INLINE fromIso #-}++iso :: (s -> a) -> (b -> t) -> Iso s t a b+iso = dimap+{-# INLINE iso #-}++withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r+withIso ai k = case ai (Exchange id id) of+  Exchange sa bt -> k sa bt++pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')+pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->+  iso (bmap sa s'a') (bmap bt b't')+  where bmap f' g' (a, b) = (f' a, g' b)++data Exchange a b s t = Exchange (s -> a) (b -> t)++instance Functor (Exchange a b s) where+  fmap f (Exchange sa bt) = Exchange sa (f . bt)+  {-# 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 #-}+  ( #. ) _ = coerce+  {-# INLINE ( #. ) #-}+  ( .# ) p _ = coerce p+  {-# INLINE ( .# ) #-}+

@@ -0,0 +1,170 @@+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Rank2Types                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeFamilyDependencies    #-}+{-# LANGUAGE TypeOperators             #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Internal.Profunctor.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.Profunctor.Lens where++import Data.Profunctor        (Profunctor(..), Strong(..))+import Data.Bifunctor+import GHC.Generics+import Data.Generics.Internal.Profunctor.Iso++type Lens s t a b+  = forall p . (Strong p) => p a b -> p s t++type LensLike p s t a b+  = p a b -> p s t+++ravel :: (ALens a b a b -> ALens a b s t) -> Lens s t a b+ravel l pab = conv (l idLens) pab+  where+    conv :: ALens a b s t -> Lens s t a b+    conv (ALens _get _set) = lens _get _set++-- | Setting+set :: ((a -> b) -> s -> t) -> (s, b) -> t+set f (s, b)+  = f  (const b) s++view :: Lens s s a a -> s -> a+view l = withLensPrim l (\get _ -> snd . get)++--withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r+--ithLens l k =+-- case l idLens of+--   ALens _get _set -> k (snd . _get) (\(s, b) -> _set ((fst $ _get s), b))++withLensPrim :: Lens s t a b -> (forall c . (s -> (c,a)) -> ((c, b) -> t) -> r) -> r+withLensPrim l k =+ case l idLens of+   ALens _get _set -> k _get _set++idLens :: ALens a b a b+idLens = ALens (fork (const ()) id) snd+{-# INLINE idLens #-}++-- | Lens focusing on the first element of a product+first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)+first+  = lens (\(a :*: b) -> (b,a)) (\(b, a') -> a' :*: b)++-- | Lens focusing on the second element of a product+second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)+second+  = lens (\(a :*: b) -> (a,b)) (\(a, b') -> a :*: b')++fork :: (a -> b) -> (a -> c) -> a -> (b, c)+fork f g a = (f a, g a)++swap :: (a, b) -> (b, a)+swap (a, b) = (b, a)++cross :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)+cross = bimap++--------------------------------------------------------------------------------++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++newtype Alongside p s t a b = Alongside { getAlongside :: p (s, a) (t, b) }++instance Profunctor p => Profunctor (Alongside p c d) where+  dimap f g (Alongside pab) = Alongside $ dimap (fmap f) (fmap g) pab++instance Strong p => Strong (Alongside p c d) where+  second' (Alongside pab) = Alongside . dimap shuffle shuffle . second' $ pab+   where+    shuffle (x,(y,z)) = (y,(x,z))++(??) :: Functor f => f (a -> b) -> a -> f b+fab ?? a = fmap ($ a) fab++-- Could implement this using primitives?+alongside :: Profunctor p =>+          LensLike (Alongside p s' t') s  t  a  b+          -> LensLike (Alongside p a b) s' t' a' b'+          -> LensLike p (s, s') (t, t') (a, a') (b, b')+alongside l1 l2+  = dimap swap swap . getAlongside . l1 . Alongside . dimap swap swap . getAlongside . l2 . Alongside++assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))+assoc3L f = assoc3 f++stron :: (Either s s', b) -> Either (s, b) (s', b)+stron (e, b) =  bimap (,b) (, b) e++choosing :: forall s t a b s' t' . Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b+choosing l r = withLensPrim l (\getl setl ->+                  withLensPrim r (\getr setr ->+                            let --g :: Either s s' -> a+                                g e = case e of+                                        Left v -> let (c, v') = getl v in (Left c, v')+                                        Right v -> let (c, v') = getr v in (Right c, v')+                                s = bimap setl setr . stron+                            in lens g s))++lens :: (s -> (c,a)) -> ((c,b) -> t) -> Lens s t a b+lens get _set = dimap get _set . second'+{-# INLINE lens #-}++------------------------------------------------------------------------------++data ALens a b s t = forall c . ALens (s -> (c,a)) ((c, b) -> t)++instance Functor (ALens a b s) where+  fmap f (ALens _get _set) = ALens _get (f . _set)++instance Profunctor (ALens a b) where+  dimap f g (ALens get _set) = ALens (get . f) (g . _set)++instance Strong (ALens a b) where+  second' (ALens get _set) = ALens get' set' --(bimap id _set . assoc)+    where+      get' (c, a1) = let (c1, a) = get a1 in ((c, c1), a)+      set' ((c, c1), b) = (c, _set (c1, b))+  {-# INLINE second' #-}++-- These are specialised versions of the Isos. 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 = mIso f++repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)+repLens f = repIso f++prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)+prodL f = prodIso f++prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)+prodR f = fromIso prodIso f++assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)+assoc3R f = fromIso assoc3 f

@@ -0,0 +1,118 @@+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE LambdaCase                #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Rank2Types                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeFamilyDependencies    #-}+{-# LANGUAGE TypeOperators             #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Internal.Profunctor.Prism+-- 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.Profunctor.Prism where++import Data.Profunctor        (Choice(..), Profunctor(..))+import Data.Tagged+import Data.Profunctor.Unsafe ((#.), (.#))+import GHC.Generics+import Data.Coerce++type APrism s t a b = Market a b a b -> Market a b s t++type Prism s t a b+  = forall p . (Choice p) => p a b -> p s t++type Prism' s a = forall p . (Choice p) => p a a -> p s s++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++prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b+prism bt seta eta = dimap seta (either id bt) (right' eta)++_Left :: Prism (Either a c) (Either b c) a b+_Left = prism Left $ either Right (Left . Right)++_Right :: Prism (Either c a) (Either c b) a b+_Right = prism Right $ either (Left . Left) Right++prismPRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b+prismPRavel l pab = (prism2prismp $ l idPrism) pab++build :: (Tagged b b -> Tagged t t) -> b -> t+build p = unTagged #. p .# Tagged++match :: Prism s t a b -> s -> Either t a+match k = withPrism k $ \_ _match -> _match++--------------------------------------------------------------------------------+-- Prism stuff++without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d)+without' k =+  withPrism k  $ \bt _ k' ->+  withPrism k' $ \dt setc ->+    prism (foldEither bt dt) $ \s -> fmap Right (setc s)+  where foldEither _ g (Right r) = g r+        foldEither f _ (Left l) = f l+{-# INLINE without' #-}++withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r+withPrism k f = case k idPrism of+  Market bt seta -> f bt seta++prism2prismp :: Market a b s t -> Prism s t a b+prism2prismp (Market bt seta) = prism bt seta++idPrism :: Market a b a b+idPrism = Market id Right++gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c+gsum f _ (L1 x) =  f x+gsum _ g (R1 y) =  g y++plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d+plus f _ (Left x) = Left (f x)+plus _ g (Right y) = Right (g y)++--------------------------------------------------------------------------------+-- 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 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 #-}+  ( #. ) _ = coerce+  {-# INLINE ( #. ) #-}+  ( .# ) p _ = coerce p+  {-# INLINE ( .# ) #-}++instance Choice (Market a b) where+  left' (Market bt seta) = Market (Left . bt) $ \case+    Left s -> case seta s of+      Left t -> Left (Left t)+      Right a -> Right a+    Right c -> Left (Right c)+  {-# INLINE left' #-}

@@ -0,0 +1,52 @@+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Rank2Types                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeFamilyDependencies    #-}+{-# LANGUAGE TypeOperators             #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Internal.VL.Iso+-- 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.VL.Iso where++import Data.Profunctor        (Profunctor(..))+import GHC.Generics+import Data.Generics.Internal.GenericN (Rec (..))++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)++-- | 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++-- | '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 #-}

@@ -0,0 +1,65 @@+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Rank2Types                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeFamilyDependencies    #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE TupleSections             #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Internal.VL.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.VL.Lens where++import Control.Applicative    (Const(..))+import Data.Functor.Identity  (Identity(..))+import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens)++-- | 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++lens2lensvl :: ALens a b 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 a b -> ALens a b 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 -> curry _set x <$> f (get x)+{-# INLINE[0] lens #-}+

@@ -0,0 +1,73 @@+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Rank2Types                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeFamilyDependencies    #-}+{-# LANGUAGE TypeOperators             #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Internal.VL.Prism+-- 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.VL.Prism where++import Data.Functor.Identity  (Identity(..))+import Data.Profunctor        (Choice(..), Profunctor(..))+import Data.Coerce+import Data.Generics.Internal.Profunctor.Prism (Market (..), plus, idPrism)+import Data.Tagged+import Data.Profunctor.Unsafe ((#.), (.#))+import Data.Monoid            (First (..))+import Control.Applicative    (Const(..))++-- | 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++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)+++match :: Prism s t a b -> s -> Either t a+match k = withPrism k $ \_ _match -> _match+{-# INLINE match #-}++(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t+(#) = build+{-# INLINE (#) #-}++prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b+prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)+{-# INLINE prism #-}++prismRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b+prismRavel l pab  = (prism2prismvl $ l idPrism) pab+{-# INLINE prismRavel #-}++type APrismVL s t a b = Market a b a (Identity b) -> Market a b s (Identity t)++withPrism :: APrismVL s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r+withPrism k f = case coerce (k (Market Identity Right)) of+                  Market bt seta -> f bt seta++prism2prismvl :: Market a b s t -> Prism s t a b+prism2prismvl  (Market bt seta) = prism bt seta+{-# INLINE prism2prismvl #-}++build :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t+build p = runIdentity #. unTagged #. p .# Tagged .# Identity+{-# INLINE build #-}

@@ -0,0 +1,91 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Rank2Types                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeFamilyDependencies    #-}+{-# LANGUAGE TypeOperators             #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Internal.VL.Traversal+-- 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.VL.Traversal where++import Data.Kind (Constraint)++-- | Type alias for traversal+type Traversal' s a+  = forall f. Applicative f => (a -> f a) -> s -> f s++type TraversalC (c :: * -> * -> Constraint) s t+  = forall f. Applicative f => (forall a b. c a b => a -> f b) -> s -> f t++type TraversalC' (c :: * -> Constraint) s+  = forall f. Applicative f => (forall a. c a => a -> f a) -> s -> f s++type Traversal s t a b+  = forall f. Applicative f => (a -> f b) -> s -> f t++type LensLikeC c f s+  = (forall a. c a => a -> f a) -> s -> f s++confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t+confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)+{-# INLINE confusing #-}++-- fuse constrained traversals+confusingC :: forall c f s. Applicative f => TraversalC' c s -> LensLikeC c f s+confusingC t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)+{-# INLINE confusingC #-}++liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a+liftCurriedYoneda fa = Curried (`yap` fa)+{-# INLINE liftCurriedYoneda #-}++yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b+yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)+{-# INLINE yap #-}++newtype Curried f a =+  Curried { runCurried :: forall r. f (a -> r) -> f r }++instance Functor f => Functor (Curried f) where+  fmap f (Curried g) = Curried (g . fmap (.f))+  {-# INLINE fmap #-}++instance (Functor f) => Applicative (Curried f) where+  pure a = Curried (fmap ($ a))+  {-# INLINE pure #-}+  Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))+  {-# INLINE (<*>) #-}++liftCurried :: Applicative f => f a -> Curried f a+liftCurried fa = Curried (<*> fa)++lowerCurried :: Applicative f => Curried f a -> f a+lowerCurried (Curried f) = f (pure id)+newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }++liftYoneda :: Functor f => f a -> Yoneda f a+liftYoneda a = Yoneda (\f -> fmap f a)++lowerYoneda :: Yoneda f a -> f a+lowerYoneda (Yoneda f) = f id++instance Functor (Yoneda f) where+  fmap f m = Yoneda (\k -> runYoneda m (k . f))++instance Applicative f => Applicative (Yoneda f) where+  pure a = Yoneda (\f -> pure (f a))+  Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)

@@ -1,3 +1,4 @@+{-# LANGUAGE PolyKinds #-} module Data.Generics.Internal.Void where  {-

@@ -22,6 +22,11 @@   , module Data.Generics.Product.Positions   , module Data.Generics.Product.Subtype   , module Data.Generics.Product.Typed+  , module Data.Generics.Product.List+  -- *Traversals+  , module Data.Generics.Product.Types+  , module Data.Generics.Product.Param+  , module Data.Generics.Product.Constraints   ) where  import Data.Generics.Product.Any@@ -29,3 +34,7 @@ import Data.Generics.Product.Positions import Data.Generics.Product.Subtype import Data.Generics.Product.Typed+import Data.Generics.Product.Types+import Data.Generics.Product.Constraints+import Data.Generics.Product.Param+import Data.Generics.Product.List

@@ -29,7 +29,7 @@     HasAny (..)   ) where -import Data.Generics.Internal.Lens+import Data.Generics.Internal.VL.Lens import Data.Generics.Product.Fields import Data.Generics.Product.Positions import Data.Generics.Product.Typed@@ -41,7 +41,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :{ -- data Human = Human --   { name    :: String

@@ -0,0 +1,57 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE UndecidableInstances  #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Constraints+-- Copyright   :  (C) 2018 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Constrained traversals.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Constraints+  ( -- *Traversals+    --+    --  $example+    HasConstraints (..)+  , HasConstraints' (..)+  ) where++import Data.Generics.Product.Internal.Constraints+import Data.Kind (Constraint)++import GHC.Generics (Generic (Rep), from, to)+import Data.Generics.Internal.VL.Traversal++class HasConstraints' (c :: * -> Constraint) s where+  constraints' :: TraversalC' c s++instance+  ( Generic s+  , GHasConstraints' c (Rep s)+  ) => HasConstraints' c s where+  constraints' = confusingC @c (\f s -> to <$> gconstraints' @c f (from s))+  {-# INLINE constraints' #-}++class HasConstraints (c :: * -> * -> Constraint) s t where+  constraints :: TraversalC c s t++instance+  ( Generic s+  , Generic t+  , GHasConstraints c (Rep s) (Rep t)+  ) => HasConstraints c s t where+  constraints f s = to <$> gconstraints @c f (from s)+  {-# INLINE constraints #-}

@@ -31,20 +31,21 @@      -- $setup     HasField (..)-  , HasField'+  , HasField' (..)    , getField   , setField   ) where  import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens+import Data.Generics.Internal.VL.Lens as VL import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.Fields+import Data.Generics.Product.Internal.Keyed  import Data.Kind    (Constraint, Type) import GHC.Generics import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)+import Data.Generics.Internal.Profunctor.Lens as P  -- $setup -- == /Running example:/@@ -55,7 +56,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 +77,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,22 +109,30 @@   --  ... 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+class HasField' (field :: Symbol) s a | s field -> a where+  field' :: VL.Lens s s a a  -- | -- >>> 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+  ( Generic s+  , ErrorUnless field s (CollectField field (Rep s))+  , GHasKey' field (Rep s) a+  ) => HasField' field s a where+  field' f s = VL.ravel (repLens . gkey @field) f s+ instance  -- see Note [Changing type parameters]   ( Generic s   , ErrorUnless field s (CollectField field (Rep s))@@ -137,15 +146,14 @@ #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+  , GHasKey' field (Rep s) a+  , GHasKey' field (Rep s') a'+  , GHasKey' field (Rep t') b'+  , GHasKey  field (Rep s) (Rep t) a b   , t ~ Infer s a' b   , s ~ Infer t b' a   ) => HasField field s t a b where--  field f s = ravel (repLens . gfield @field) f s+  field f s = VL.ravel (repLens . gkey @field) f s  -- -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where

@@ -0,0 +1,141 @@+{-# LANGUAGE AllowAmbiguousTypes       #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE FunctionalDependencies    #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE Rank2Types                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE TypeFamilyDependencies    #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE UndecidableInstances      #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Internal.Constraints+-- Copyright   :  (C) 2017 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive constrained traversals+--+-----------------------------------------------------------------------------++-- TODO: use type-changing variant++module Data.Generics.Product.Internal.Constraints+  (+    GHasConstraints (..)+  , GHasConstraints' (..)+  , HList (..)+  ) where++import Data.Kind (Type, Constraint)+import GHC.Generics+import Data.Generics.Internal.VL.Iso+import Data.Generics.Internal.VL.Traversal++-- | Constrained traversal.+class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where+  gconstraints' :: forall g x.+    Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)++instance+  ( GHasConstraints' c l+  , GHasConstraints' c r+  ) => GHasConstraints' c (l :*: r) where+  gconstraints' f (l :*: r)+    = (:*:) <$> gconstraints' @c f l <*> gconstraints' @c f r++instance+  ( GHasConstraints' c l+  , GHasConstraints' c r+  ) => GHasConstraints' c (l :+: r) where+  gconstraints' f (L1 l) = L1 <$> gconstraints' @c f l+  gconstraints' f (R1 r) = R1 <$> gconstraints' @c f r++instance c a => GHasConstraints' c (Rec0 a) where+  gconstraints' = kIso++instance GHasConstraints' c f+  => GHasConstraints' c (M1 m meta f) where+  gconstraints' f (M1 x) = M1 <$> gconstraints' @c f x++instance GHasConstraints' c U1 where+  gconstraints' _ _ = pure U1++--------------------------------------------------------------------------------++class GHasConstraints (c :: * -> * -> Constraint) s t where+  gconstraints :: TraversalC c (s x) (t x)++instance+  ( GHasConstraints c l l'+  , GHasConstraints c r r'+  ) => GHasConstraints c (l :*: r) (l' :*: r') where+  gconstraints f (l :*: r)+    = (:*:) <$> gconstraints @c f l <*> gconstraints @c f r++instance+  ( GHasConstraints c l l'+  , GHasConstraints c r r'+  ) => GHasConstraints c (l :+: r) (l' :+: r') where+  gconstraints f (L1 l) = L1 <$> gconstraints @c f l+  gconstraints f (R1 r) = R1 <$> gconstraints @c f r++instance GHasConstraints c s t+  => GHasConstraints c (M1 i m s) (M1 i m t) where+  gconstraints f (M1 x) = M1 <$> gconstraints @c f x++instance GHasConstraints c U1 U1 where+  gconstraints _ _ = pure U1++instance GHasConstraints c V1 V1 where+  gconstraints _ = pure++instance c a b => GHasConstraints c (Rec0 a) (Rec0 b) where+  gconstraints = kIso++--------------------------------------------------------------------------------++-- | Multi-traversal+--type GHasTypes rep as = GHasConstraints (Contains as) rep++-- Try to use a function from the list, or default to 'pure' if not present+{-+gtypes+  :: forall as x f g.+  ( GHasTypes f as+  , Applicative g+  ) => HList (Functions as g) -> f x -> g (f x)+gtypes hl s = gconstraints @(Contains as) (pick hl) s+-}++--------------------------------------------------------------------------------++data HList (ts :: [Type]) where+  HNil :: HList '[]+  (:>) :: a -> HList as -> HList (a ': as)+infixr 5 :>++-- >>> :kind! Functions '[Int, Char, Bool] Maybe+-- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool]+type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where+  Functions '[] _ = '[]+  Functions (t ': ts) g = ((t -> g t) ': Functions ts g)++class Contains as a where+  pick :: Applicative g => HList (Functions as g) -> a -> g a++instance {-# OVERLAPPING #-} Contains (a ': as) a where+  pick (h :> _) = h++instance Contains as a => Contains (b ': as) a where+  pick (_ :> hs) = pick hs++instance Contains '[] a where+  pick _ = pure

@@ -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

@@ -0,0 +1,60 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeInType             #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++#if __GLASGOW_HASKELL__ == 802+{-# OPTIONS_GHC -fno-solve-constant-dicts #-}+#endif++--------------------------------------------------------------------------------+-- |+-- Module      : Data.Generics.Product.Internal.Keyed+-- Copyright   : (C) 2018 Csongor Kiss+-- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- License     : BSD3+-- Stability   : experimental+-- Portability : non-portable+--+--------------------------------------------------------------------------------++module Data.Generics.Product.Internal.Keyed+  ( GHasKey (..)+  , GHasKey'+  ) where++import Data.Generics.Product.Internal.List+import Data.Kind+import GHC.Generics+import Data.Generics.Internal.Profunctor.Lens+import Data.Generics.Internal.Profunctor.Iso++class GHasKey (key :: k) (s :: Type -> Type) (t :: Type -> Type) a b | s key -> a, t key -> b where+  gkey :: Lens (s x) (t x) a b++type GHasKey' key s a = GHasKey key s s a a++instance (GHasKey key l l' a b, GHasKey key r r' a b) =>  GHasKey key (l :+: r) (l' :+: r') a b where+  gkey = sumIso . choosing (gkey @key) (gkey @key)+  {-# INLINE gkey #-}++instance (GHasKey key f g a b) => GHasKey key (M1 D meta f) (M1 D meta g) a b where+  gkey = ravel (mLens . gkey @key)+  {-# INLINE gkey #-}++instance+  ( Elem as key i a+  , Elem bs key i b+  , IndexList i as bs a b+  , GIsList k f g as bs+  ) => GHasKey (key :: k) (M1 C meta f) (M1 C meta g) a b where+  gkey = mLens . glist @k . point @i+  {-# INLINE gkey #-}

@@ -0,0 +1,335 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TupleSections          #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeInType             #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++#if __GLASGOW_HASKELL__ == 802+{-# OPTIONS_GHC -fno-solve-constant-dicts #-}+#endif+++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Internal.List+-- Copyright   :  (C) 2017 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.Internal.List+  ( GIsList (..)+  , IndexList (..)+  , List (..)+  , type (++)+  , Elem+  , ListTuple (..)+  , TupleToList+  ) where++import GHC.TypeLits+import Data.Semigroup++import Data.Kind    (Type)+import GHC.Generics+import Data.Profunctor+import Data.Generics.Internal.Profunctor.Lens+import Data.Generics.Internal.Profunctor.Iso++data List (as :: [(m, Type)]) where+  Nil :: List '[]+  (:>) :: a -> List as -> List ('(s, a) ': as)++infixr 5 :>++type family ((as :: [k]) ++ (bs :: [k])) :: [k] where+  '[]       ++ bs = bs+  (a ': as) ++ bs = a ': as ++ bs++instance Semigroup (List '[]) where+  _ <> _ = Nil++instance Monoid (List '[]) where+  mempty  = Nil+  mappend _ _ = Nil++instance (Semigroup a, Semigroup (List as)) => Semigroup (List ('(k, a) ': as)) where+  (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)++instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, a) ': as)) where+  mempty = mempty :> mempty+  mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys++class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a+instance {-# OVERLAPPING #-} pos ~ 0 => Elem ('(key, a) ': xs) key pos a+instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a++class GIsList+  (m :: Type)+  (f :: Type -> Type)+  (g :: Type -> Type)+  (as :: [(m, Type)])+  (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where++  glist :: Iso (f x) (g x) (List as) (List bs)++  -- We define this reversed version, otherwise uses of `fromIso glist` are not+  -- properly inlined by GHC 8.0.2.+  -- This is not actually used.+  glistR :: Iso (List bs) (List as) (g x) (f x)+  glistR = fromIso (glist @m)++instance+  ( GIsList m l l' as as'+  , GIsList m r r' bs bs'+  , Appending List as bs cs as' bs' cs'+  , cs ~ (as ++ bs)+  , cs' ~ (as' ++ bs')+  ) => GIsList m (l :*: r) (l' :*: r') cs cs' where++  glist = prodIso . pairing (glist @m) (glist @m) . appending+  {-# INLINE glist #-}++instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where+  glist = mIso . glist @m+  {-# INLINE glist #-}++instance {-# OVERLAPS #-}+  GIsList Symbol+          (S1 ('MetaSel ('Just field) u s i) (Rec0 a))+          (S1 ('MetaSel ('Just field) u s i) (Rec0 b))+          '[ '(field, a)] '[ '(field, b)] where+  glist = mIso . kIso . singleton+  {-# INLINE glist #-}++instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where+  glist = kIso . singleton+  {-# INLINE glist #-}++instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where+  glist = kIso . singleton+  {-# INLINE glist #-}++instance GIsList m U1 U1 '[] '[] where+  glist = iso (const Nil) (const U1)+  {-# INLINE glist #-}++--------------------------------------------------------------------------------+-- | as ++ bs === cs+class Appending f (as :: [k]) bs cs (as' :: [k]) bs' cs' | as bs cs cs' -> as' bs', as' bs' cs cs' -> as bs, as bs -> cs, as' bs' -> cs' where+  appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs')++-- | [] ++ bs === bs+instance Appending List '[] bs bs '[] bs' bs' where+  appending = iso (\(_, b) -> b) (Nil,)++-- | (a : as) ++ bs === (a : cs)+instance+  Appending List as bs cs as' bs' cs' -- as ++ bs == cs+  => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where+  appending+    = pairing (fromIso consing) id -- ((a, as), bs)+    . assoc3                       -- (a, (as, bs))+    . pairing id appending         -- (a, cs)+    . consing                      -- (a : cs)++singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)])+singleton = iso (:> Nil) (\(x :> _) -> x)++consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs))+consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))++--------------------------------------------------------------------------------+class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where+  point :: Lens (List as) (List bs) a b++instance {-# OVERLAPPING #-}+  ( as ~ ('(f, a) ': as')+  , bs ~ ('(f, b) ': as')+  ) => IndexList 0 as bs a b where+  point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)+  {-# INLINE point #-}++instance+  ( IndexList (n - 1) as' bs' a b+  , as ~ ('(f, x) ': as')+  , bs ~ ('(f, x) ': bs')+  ) => IndexList n as bs a b where+  point = fromIso consing . alongside id (point @(n-1)) . second'+  {-# INLINE point #-}++--------------------------------------------------------------------------------+-- * Convert tuples to/from HLists++class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where+  type ListToTuple as :: Type+  tupled :: Iso' (List as) tuple+  tupled = iso listToTuple tupleToList++  tupleToList :: tuple -> List as+  listToTuple :: List as -> tuple++instance ListTuple () '[] where+  type ListToTuple '[] = ()+  tupleToList _ = Nil+  listToTuple _ = ()++instance ListTuple a '[ '(fa, a)] where+  type ListToTuple '[ '(fa, a)] = a+  tupleToList a+    = a :> Nil+  listToTuple (a :> Nil)+    = a++instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where+  type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b)+  tupleToList (a, b)+    = a :> b :> Nil+  listToTuple (a :> b :> Nil)+    = (a, b)++instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, 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) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] where+  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, 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)++type family TupleToList a where+  TupleToList () = '[]+  TupleToList (a, b) = '[ '( '(), a), '( '(), b)]+  TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)]+  TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)]+  TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)]+  TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)]+  TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)]+  TupleToList (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, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)]+  TupleToList (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, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)]+  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)]+  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)]+  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)]+  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)]+  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)]+  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)]+  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)]+  TupleToList a = '[ '( '(), a)]

@@ -33,42 +33,35 @@   , Size   ) where -import Data.Generics.Internal.Lens-+import Data.Generics.Product.Internal.List import Data.Kind      (Type) import Data.Type.Bool (If, Not) import GHC.Generics-import GHC.TypeLits   (type (<=?), type (+), Nat)+import GHC.TypeLits   (type (<=?), type (+), type (-), Nat)+import Data.Generics.Internal.Profunctor.Lens+import Data.Generics.Internal.Profunctor.Iso  -- |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+class GHasPosition (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s i -> a, t i -> b, s t i -> b where   gposition :: Lens (s x) (t x) a b -type GHasPosition' i s a = GHasPosition 1 i s s a a+type GHasPosition' i s a = GHasPosition 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 i l l' a b, GHasPosition i r r' a b) =>  GHasPosition i (l :+: r) (l' :+: r') a b where+  gposition = \x -> sumIso (choosing (gposition @i) (gposition @i) x)+  {-# INLINE gposition #-} -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 GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where+  gposition x = mLens (gposition @i x)+  {-# INLINE gposition #-}  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+  ( IndexList (i - 1) as bs a b+  , GIsList () f g as bs+  ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where+  gposition x = mIso (glist @() (point @(i - 1) x))+  {-# INLINE gposition #-}  type family Size f :: Nat where   Size (l :*: r)

@@ -31,11 +31,11 @@   ) where  import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens-import Data.Generics.Product.Internal.Fields+import Data.Generics.Product.Internal.Keyed  import Data.Kind (Type) import GHC.Generics+import Data.Generics.Internal.Profunctor.Lens  -------------------------------------------------------------------------------- -- * Generic upcasting@@ -47,10 +47,10 @@   gupcast rep = gupcast rep :*: gupcast rep  instance-  GHasField field sub sub t t+  GHasKey field sub sub t t   => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where -  gupcast r = M1 (K1 (r ^. gfield @field))+  gupcast r = M1 (K1 (view (gkey @field) r))  instance GUpcast sub sup => GUpcast sub (C1 c sup) where   gupcast = M1 . gupcast@@ -84,9 +84,9 @@   gsmashLeaf :: sup p -> sub p -> sub p  instance-  GHasField field sup sup t t+  GHasKey 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))+  gsmashLeaf sup _ = M1 (K1 (view (gkey @field) sup))  instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where   gsmashLeaf _ = id

@@ -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

@@ -0,0 +1,78 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MonoLocalBinds         #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeInType             #-}+{-# LANGUAGE UndecidableInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.List+-- Copyright   :  (C) 2017 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.List+  ( IsList (..)+  , IsRecord+  , IsRecord'+  ) where++import Data.Generics.Product.Internal.List+import Data.Kind+import GHC.Generics+import GHC.TypeLits+import Data.Generics.Internal.Profunctor.Iso++class IsList+  (m :: Type)+  (f :: Type)+  (g :: Type)+  (as :: [(m, Type)])+  (bs :: [(m, Type)]) | m f -> as, m g -> bs where+  list  :: Iso f g (List as) (List bs)++instance+  ( Generic f+  , Generic g+  , GIsList m (Rep f) (Rep g) as bs+  ) => IsList m f g as bs where+  list = repIso . glist @m+  {-# INLINE list #-}++class IsList Symbol f g as bs => IsRecord f g (as :: [(Symbol, Type)]) (bs :: [(Symbol, Type)]) | f -> as, g -> bs+instance IsList Symbol f g as bs => IsRecord f g as bs++class IsRecord f f as as => IsRecord' f (as :: [(Symbol, Type)]) | f -> as+instance IsRecord f f as as => IsRecord' f as++-- example (TODO: move elsewhere)+--class PrintRecord (rl :: [(Symbol, Type)]) where+--  printRecord' :: List rl -> String+--+--instance PrintRecord '[] where+--  printRecord' _ = ""+--+--instance (KnownSymbol field, Show a, PrintRecord xs) => PrintRecord ('(field, a) ': xs) where+--  printRecord' (x :> xs) = show x ++ ", " ++ printRecord' xs+--+--printRecord :: (IsRecord' rec rl, PrintRecord rl) => rec -> String+--printRecord rec = printRecord' (rec ^. list)+--+--data MyRecord = MyRecord+--  { field1 :: Int+--  , field2 :: String+--  , field3 :: Bool+--  } deriving Generic+--+-- >>> printRecord (MyRecord 10 "hello" False)+-- "10, \"hello\", False, "

@@ -0,0 +1,114 @@+{-# 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) 2018 Csongor Kiss+-- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- License     : BSD3+-- Stability   : experimental+-- Portability : non-portable+--+-- Derive traversal 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 (..)+  ) where++import GHC.TypeLits+import Data.Generics.Internal.Void+import Data.Generics.Internal.Families.Changing+import Data.Generics.Internal.VL.Traversal++import GHC.Generics+import Data.Kind+import Data.Generics.Internal.VL.Iso+import Data.Generics.Internal.GenericN++class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where+  param :: Applicative g => (a -> g b) -> s -> g t++instance+  ( GenericN s+  , GenericN t+  -- TODO: merge the old 'Changing' code with 'GenericN'+  , s ~ Infer t (P n b 'PTag) a+  , t ~ Infer s (P n a 'PTag) b+  , Error ((ArgCount s) <=? n) n (ArgCount s) s+  , a ~ ArgAt s n+  , b ~ ArgAt t n+  , GHasParam n (RepN s) (RepN t) a b+  ) => HasParam n s t a b where++  param = confusing (\f s -> toN <$> gparam @n f (fromN s))+  {-# INLINE param #-}++type family Error (b :: Bool) (expected :: Nat) (actual :: Nat) (s :: Type) :: Constraint where+  Error 'False _ _ _+    = ()++  Error 'True expected actual typ+    = TypeError+        (     'Text "Expected a type with at least "+        ':<>: 'ShowType (expected + 1)+        ':<>: 'Text " parameters, but "+        ':$$: 'ShowType typ+        ':<>: 'Text " only has "+        ':<>: 'ShowType actual+        )++-- TODO [1.0.0.0]: none of this is needed.++instance {-# OVERLAPPING #-} HasParam p (Void1 a) (Void1 b) a b where+  param = undefined++class GHasParam (p :: Nat) s t a b where+  gparam :: forall g (x :: Type).  Applicative g => (a -> g b) -> s x -> g (t x)++instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :*: r) (l' :*: r') a b where+  gparam f (l :*: r) = (:*:) <$> gparam @p f l <*> gparam @p f r++instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :+: r) (l' :+: r') a b where+  gparam f (L1 l) = L1 <$> gparam @p f l+  gparam f (R1 r) = R1 <$> gparam @p f r++instance GHasParam p U1 U1 a b where+  gparam _ _ = pure U1++instance GHasParam p s t a b => GHasParam p (M1 m meta s) (M1 m meta t) a b where+  gparam f (M1 x) = M1 <$> gparam @p f x++-- the parameter we're looking for+instance GHasParam p (Rec (param p) a) (Rec (param p) b) a b where+  gparam = recIso++-- other recursion+instance {-# OVERLAPPABLE #-}+  ( GHasParamRec (LookupParam si p) s t a b+  -- TODO: reindex `ti`+  ) => GHasParam p (Rec si s) (Rec ti t) a b where+  gparam f (Rec (K1 x)) = Rec . K1 <$> gparamRec @(LookupParam si p) f x++class GHasParamRec (param :: Maybe Nat) s t a b | param t a b -> s, param s a b -> t where+  gparamRec :: forall g.  Applicative g => (a -> g b) -> s -> g t++instance GHasParamRec 'Nothing a a c d where+  gparamRec _ = pure++instance (HasParam n s t a b) => GHasParamRec ('Just n) s t a b where+  gparamRec = param @n

@@ -32,13 +32,13 @@      -- $setup     HasPosition (..)-  , HasPosition'+  , HasPosition' (..)    , getPosition   , setPosition   ) where -import Data.Generics.Internal.Lens+import Data.Generics.Internal.VL.Lens as VL import Data.Generics.Internal.Void import Data.Generics.Internal.Families import Data.Generics.Product.Internal.Positions@@ -47,6 +47,7 @@ import Data.Type.Bool (type (&&)) import GHC.Generics import GHC.TypeLits   (type (<=?),  Nat, TypeError, ErrorMessage(..))+import Data.Generics.Internal.Profunctor.Lens  -- $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,16 +87,25 @@   --  ...   --  ... 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 a | s i -> a where+  position' :: VL.Lens s s a a  getPosition :: forall i s a. HasPosition' i s a => s -> a-getPosition s = s ^. position @i+getPosition s = s ^. position' @i  setPosition :: forall i s a. HasPosition' i s a => a -> s -> s-setPosition = set (position @i)+setPosition = VL.set (position' @i) +instance+  ( Generic s+  , ErrorUnless i s (0 <? i && i <=? Size (Rep s))+  , GHasPosition' i (Rep s) a+  ) => HasPosition' i s a where+  position' f s = VL.ravel (repLens . gposition @i) f s+  {-# INLINE position' #-}+ instance  -- see Note [Changing type parameters]   ( Generic s   , ErrorUnless i s (0 <? i && i <=? Size (Rep s))@@ -111,13 +121,14 @@   , Generic t'   , GHasPosition' i (Rep s) a   , GHasPosition' i (Rep s') a'-  , GHasPosition 1 i (Rep s) (Rep t) a b+  , GHasPosition 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 -  position f s = ravel (repLens . gposition @1 @i) f s+  position = VL.ravel (repLens . gposition @i)+  {-# INLINE position #-}  -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where

@@ -33,13 +33,14 @@   ) where  import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens+import Data.Generics.Internal.VL.Lens as VL 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 Data.Generics.Internal.Profunctor.Lens hiding (set)  -- $setup -- == /Running example:/@@ -49,7 +50,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 +81,9 @@   --   -- >>> 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 (uncurry smash . swap)    -- |Cast the more specific subtype to the more general supertype   --@@ -103,7 +104,7 @@   -- >>> 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)    {-# MINIMAL super | smash, upcast #-} 

@@ -19,7 +19,7 @@ -- Stability   :  experimental -- Portability :  non-portable ----- Derive record field getters and setters generically.+-- Derive lenses of a given type in a product. -- ----------------------------------------------------------------------------- @@ -31,13 +31,14 @@   ) where  import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens+import Data.Generics.Internal.VL.Lens as VL import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.Typed+import Data.Generics.Product.Internal.Keyed  import Data.Kind    (Constraint, Type) import GHC.Generics (Generic (Rep)) import GHC.TypeLits (TypeError, ErrorMessage (..))+import Data.Generics.Internal.Profunctor.Lens  -- $setup -- == /Running example:/@@ -46,7 +47,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> :m +Data.Generics.Internal.VL.Lens -- >>> :{ -- data Human --   = Human@@ -91,9 +92,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) (uncurry (setTyped @a) . swap)+  {-# INLINE typed #-}    -- |Get field at type.   getTyped :: s -> a@@ -101,17 +103,17 @@    -- |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+  , GHasKey a (Rep s) (Rep s) a a   ) => HasType a s where -  typed = ravel (repLens . gtyped)+  typed f s = VL.ravel (repLens . gkey @a) f s  -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} HasType a Void where

@@ -0,0 +1,163 @@+{-# 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) 2017 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+    --+    --  $example+    HasTypes+  , types+  ) where++import Data.Kind++import GHC.Generics+import Data.Generics.Internal.VL.Traversal++-- TODO [1.0.0.0]: use type-changing variant internally++types :: forall a s. HasTypes s a => Traversal' s a+types = types_ @s @a+{-# INLINE types #-}++class HasTypes s a where+  types_ :: Traversal' s a++  default types_ :: Traversal' s a+  types_ _ = pure+  {-# INLINE types_ #-}++instance+  ( HasTypes' (Interesting s a) s a+  ) => HasTypes s a where+  types_ = types' @(Interesting s a)+  {-# INLINE types_ #-}++class HasTypes' (t :: Bool) s a where+  types' :: Traversal' s a++instance+  ( GHasTypes (Rep s) a+  , Generic s+  ) => HasTypes' 'True s a where+  types' f s = to <$> gtypes_ f (from s)+  --{-# INLINE types' #-}++instance HasTypes' 'False s a where+  types' _ = pure+  --{-# INLINE types' #-}++instance {-# OVERLAPPING #-} HasTypes Bool a+instance {-# OVERLAPPING #-} HasTypes Char a+instance {-# OVERLAPPING #-} HasTypes Double a+instance {-# OVERLAPPING #-} HasTypes Float a+instance {-# OVERLAPPING #-} HasTypes Int a+instance {-# OVERLAPPING #-} HasTypes Integer a+instance {-# OVERLAPPING #-} HasTypes Ordering a++--------------------------------------------------------------------------------++class GHasTypes s a where+  gtypes_ :: Traversal' (s x) a++instance+  ( GHasTypes l a+  , GHasTypes r a+  ) => GHasTypes (l :*: r) a where+  gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r+  {-# INLINE gtypes_ #-}++instance+  ( GHasTypes l a+  , GHasTypes r a+  ) => GHasTypes (l :+: r) a where+  gtypes_ f (L1 l) = L1 <$> gtypes_ f l+  gtypes_ f (R1 r) = R1 <$> gtypes_ f r+  {-# INLINE gtypes_ #-}++instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where+  gtypes_ f (M1 s) = M1 <$> gtypes_ f s+  {-# INLINE gtypes_ #-}++instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where+  gtypes_ f (K1 x) = K1 <$> f x+  {-# INLINE gtypes_ #-}++instance HasTypes b a => GHasTypes (Rec0 b) a where+  gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x+  {-# INLINE gtypes_ #-}++instance GHasTypes U1 a where+  gtypes_ _ _ = pure U1+  {-# INLINE gtypes_ #-}++instance GHasTypes V1 a where+  gtypes_ _ = pure+  {-# INLINE gtypes_ #-}++type Interesting f a = Snd (Interesting' (Rep f) a '[f])++type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where+  Interesting' (M1 _ m f) t seen+    = Interesting' f t seen+  -- The result of the left branch is passed on to the right branch in order to avoid duplicate work+  Interesting' (l :*: r) t seen+    = InterestingOr (Interesting' l t seen) r t+  Interesting' (l :+: r) t seen+    = InterestingOr (Interesting' l t seen) r t+  Interesting' (Rec0 t) t seen+    = '(seen, 'True)+  Interesting' (Rec0 Char)     _ seen = '(seen ,'False)+  Interesting' (Rec0 Double)   _ seen = '(seen ,'False)+  Interesting' (Rec0 Float)    _ seen = '(seen ,'False)+  Interesting' (Rec0 Int)      _ seen = '(seen ,'False)+  Interesting' (Rec0 Integer)  _ seen = '(seen ,'False)+  Interesting' (Rec0 r) t seen+    = InterestingUnless (Elem r seen) (Rep r) t r seen+  Interesting' _ _ seen+    = '(seen, 'False)++-- Short circuit+-- Note: we only insert 'r' to the seen list if it's not already there (which is precisely when `s` is 'False)+type family InterestingUnless (s :: Bool) f (a :: Type) (r :: Type) (seen :: [Type]) :: ([Type], Bool) where+  InterestingUnless 'True _ _ _ seen = '(seen, 'False)+  InterestingUnless 'False f a r seen = Interesting' f a (r ': seen)++-- Short circuit+type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where+  InterestingOr '(seen, 'True) _ _ = '(seen, 'True)+  InterestingOr '(seen, 'False) r t = Interesting' r t seen++type family Elem a as where+  Elem a (a ': _) = 'True+  Elem a (_ ': as) = Elem a as+  Elem a '[] = 'False++type family Snd a where+  Snd '(_, b) = b+

@@ -28,9 +28,9 @@     AsAny (..)   ) where -import Data.Generics.Internal.Lens import Data.Generics.Sum.Constructors import Data.Generics.Sum.Typed+import Data.Generics.Internal.VL.Prism  -- $setup -- == /Running example:/@@ -39,7 +39,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> :m +Data.Generics.Internal.VL.Prism -- >>> :{ -- data Animal --   = Dog Dog@@ -86,7 +86,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

@@ -10,6 +10,7 @@ {-# LANGUAGE TypeFamilies           #-} {-# LANGUAGE TypeOperators          #-} {-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE FlexibleContexts       #-}  ----------------------------------------------------------------------------- -- |@@ -29,16 +30,19 @@      -- $setup     AsConstructor (..)+  , AsConstructor' (..)   ) where  import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens import Data.Generics.Internal.Void import Data.Generics.Sum.Internal.Constructors  import Data.Kind    (Constraint, Type) import GHC.Generics (Generic (Rep)) import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))+import Data.Generics.Internal.VL.Prism+import Data.Generics.Internal.Profunctor.Iso+import Data.Generics.Internal.Profunctor.Prism (prismPRavel)  -- $setup -- == /Running example:/@@ -49,7 +53,7 @@ -- >>> :set -XFlexibleContexts -- >>> :set -XTypeFamilies -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> :m +Data.Generics.Internal.VL.Prism -- >>> :m +Data.Generics.Product.Fields -- >>> :m +Data.Function -- >>> :{@@ -99,9 +103,20 @@   --  ...   _Ctor :: Prism s t a b +class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where+  _Ctor' :: Prism s s a a+ instance   ( Generic s   , ErrorUnless ctor s (HasCtorP ctor (Rep s))+  , GAsConstructor' ctor (Rep s) a+  ) => AsConstructor' ctor s a where+  _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta+  {-# INLINE _Ctor' #-}++instance+  ( Generic s+  , ErrorUnless ctor s (HasCtorP ctor (Rep s))   , Generic t   -- see Note [CPP in instance constraints] #if __GLASGOW_HASKELL__ < 802@@ -120,7 +135,8 @@   , s ~ Infer t b' a   ) => AsConstructor ctor s t a b where -  _Ctor = repIso . _GCtor @ctor+  _Ctor eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta+  {-# INLINE _Ctor #-}  -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where

@@ -30,11 +30,14 @@   ) where  import Data.Generics.Internal.Families-import Data.Generics.Internal.HList-import Data.Generics.Internal.Lens+import Data.Generics.Product.Internal.List  import GHC.Generics import GHC.TypeLits (Symbol)+import Data.Kind+import Data.Generics.Internal.Profunctor.Lens+import Data.Generics.Internal.Profunctor.Iso+import Data.Generics.Internal.Profunctor.Prism  -- |As 'AsConstructor' but over generic representations as defined by --  "GHC.Generics".@@ -44,25 +47,31 @@ type GAsConstructor' ctor s a = GAsConstructor ctor s s a a  instance-  ( GCollectible f as-  , GCollectible g bs+  ( GIsList Type f f as as+  , GIsList Type g g bs 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)+  _GCtor = prism (M1 . view (fromIso (glist @Type)) . tupleToList) (Right . listToTuple . view (glist @Type) . unM1)+  {-# INLINE _GCtor #-} + 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)+  {-# INLINE _GCtor #-}  instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where   _GCtor = mIso . _GCtor @ctor+  {-# INLINE _GCtor #-}  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+  {-# INLINE _GSumCtor #-}  instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where   _GSumCtor = right . _GCtor @ctor+  {-# INLINE _GSumCtor #-}

@@ -1,7 +1,10 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE KindSignatures        #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeOperators         #-}@@ -25,50 +28,81 @@   ( GAsSubtype (..)   ) where -import Data.Generics.Internal.HList+import Data.Generics.Product.Internal.List import Data.Generics.Sum.Internal.Typed  import Data.Kind import GHC.Generics+import Data.Generics.Internal.Profunctor.Iso+import Data.Generics.Internal.Profunctor.Prism+import Data.Generics.Internal.Families.Has  -- |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)+  _GSub :: Prism' (supf x) (subf x)  instance-  ( GAsSubtype l supf-  , GAsSubtype r supf-  ) => GAsSubtype (l :+: r) supf where+  ( GSplash sub sup+  , GDowncast sub sup+  ) => GAsSubtype sub sup where+  _GSub f = (prism _GSplash _GDowncast) f+  {-# INLINE[0] _GSub #-} -  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)+-------------------------------------------------------------------------------- +class GSplash (sub :: Type -> Type) (sup :: Type -> Type) where+  _GSplash :: sub x -> sup x++instance (GSplash a sup, GSplash b sup) => GSplash (a :+: b) sup where+  _GSplash (L1 rep) = _GSplash rep+  _GSplash (R1 rep) = _GSplash rep+ instance-  ( GAsType supf a-  , GCollectible subf as-  , ListTuple a as-  ) => GAsSubtype (C1 meta subf) supf where+  ( GIsList () subf subf as as+  , GAsType supf as+  ) => GSplash (C1 meta subf) supf where+  _GSplash p = build ((_GTyped . fromIso (glist @()) . fromIso mIso)) p -  ginjectSub-    = ginjectTyped . listToTuple . gtoCollection . unM1-  gprojectSub-    = fmap (M1 . gfromCollection . tupleToList) . gprojectTyped+instance GSplash sub sup => GSplash (D1 c sub) sup where+  _GSplash (M1 m) = _GSplash m -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+class GDowncast sub sup where+  _GDowncast :: sup x -> Either (sup x) (sub x)++instance+  ( GIsList () sup sup as as+  , GDowncastC (HasPartialTypeP as sub) sub sup+  ) => GDowncast sub (C1 m sup) where+  _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of+    Left _ -> Left (M1 m)+    Right r -> Right r++instance (GDowncast sub l, GDowncast sub r) => GDowncast sub (l :+: r) where+  _GDowncast (L1 x) = case _GDowncast x of+    Left _ -> Left (L1 x)+    Right r -> Right r+  _GDowncast (R1 x) = case _GDowncast x of+    Left _ -> Left (R1 x)+    Right r -> Right r++instance GDowncast sub sup => GDowncast sub (D1 m sup) where+  _GDowncast (M1 m) = case _GDowncast m of+    Left _ -> Left (M1 m)+    Right r -> Right r++class GDowncastC (contains :: Bool) sub sup where+  _GDowncastC :: sup x -> Either (sup x) (sub x)++instance GDowncastC 'False sub sup where+  _GDowncastC sup = Left sup++instance+  ( GAsType sub subl+  , GIsList () sup sup subl subl+  ) => GDowncastC 'True sub sup where+  _GDowncastC sup = Right (build (_GTyped . fromIso (glist @())) sup)+  {-# INLINE _GDowncastC #-}+

@@ -1,14 +1,14 @@-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE KindSignatures         #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}  ----------------------------------------------------------------------------- -- |@@ -29,60 +29,39 @@  import Data.Kind import GHC.Generics+import Data.Tagged  import Data.Generics.Internal.Families-import Data.Generics.Internal.HList-import Data.Generics.Internal.Lens+import Data.Generics.Product.Internal.List+import Data.Generics.Internal.Profunctor.Iso+import Data.Generics.Internal.Profunctor.Prism  -- |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+class GAsType (f :: Type -> Type) (as :: [((), Type)]) where+  _GTyped :: Prism (f x) (f x) (List as) (List as)+-- We create this specialised version as we use it in the subtype prism+-- If we don't create it, the opportunity for specialisation is only+-- created after specialisation happens, I think a late specialisation pass+-- would pick up this case.+{-# SPECIALISE _GTyped  :: (Tagged b b -> Tagged t t) #-} -  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+  ( GIsList () f f as as+  ) => GAsType (M1 C meta f) as where+  _GTyped = mIso . glist @() -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 GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where+  _GTyped = _GSumTyped @(HasPartialTypeP a l)  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)+  _GTyped = mIso . _GTyped -  ginjectSumTyped  :: a -> (l :+: r) x-  gprojectSumTyped :: (l :+: r) x -> Either ((l :+: r) x) a+class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where+  _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List 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+  _GSumTyped = left . _GTyped  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+  _GSumTyped = right . _GTyped

@@ -1,7 +1,9 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MonoLocalBinds        #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE TypeSynonymInstances  #-} {-# LANGUAGE UndecidableInstances  #-}@@ -26,11 +28,12 @@     AsSubtype (..)   ) where -import Data.Generics.Internal.Lens import Data.Generics.Internal.Void import Data.Generics.Sum.Internal.Subtype -import GHC.Generics (Generic (Rep, to, from))+import GHC.Generics (Generic (Rep))+import Data.Generics.Internal.VL.Prism+import Data.Generics.Internal.Profunctor.Iso  -- $setup -- == /Running example:/@@ -39,7 +42,7 @@ -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> :m +Data.Generics.Internal.VL.Prism -- >>> :{ -- data Animal --   = Dog Dog@@ -86,15 +89,19 @@   --  >>> duck ^? _Sub :: Maybe FourLeggedAnimal   --  Nothing   _Sub :: Prism' sup sub-  _Sub = prism injectSub projectSub+  _Sub = prism injectSub (\i -> maybe (Left i) Right (projectSub i))    -- |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@@ -102,8 +109,8 @@   , GAsSubtype (Rep sub) (Rep sup)   ) => AsSubtype sub sup where -  injectSub  = to . ginjectSub . from-  projectSub = either (Left . to) (Right . to) . gprojectSub . from+  _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f+  {-# INLINE[2] _Sub #-}  -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} AsSubtype a Void where

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes    #-} {-# LANGUAGE DataKinds              #-} {-# LANGUAGE FlexibleContexts       #-}@@ -35,15 +36,18 @@ import Data.Generics.Sum.Internal.Typed  import Data.Generics.Internal.Families-import Data.Generics.Internal.Lens import Data.Generics.Internal.Void+import Data.Generics.Product.Internal.List+import Data.Generics.Internal.VL.Prism+import Data.Generics.Internal.Profunctor.Iso+import Data.Generics.Internal.Profunctor.Prism (prismPRavel)  -- $setup -- >>> :set -XTypeApplications -- >>> :set -XDataKinds -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics--- >>> :m +Data.Generics.Internal.Lens+-- >>> :m +Data.Generics.Internal.VL.Prism -- >>> :{ -- data Animal --   = Dog Dog@@ -84,25 +88,30 @@   --  ... Turtle   --  ...   _Typed :: Prism' s a+  _Typed = prism injectTyped (\i -> maybe (Left i) Right (projectTyped i))    -- |Inject by type.   injectTyped :: a -> s+  injectTyped+    = build _Typed    -- |Project by type.   projectTyped :: s -> Maybe a+  projectTyped+    = either (const Nothing) Just . match _Typed +  {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}+ instance   ( Generic s-  , ErrorUnlessOne a s (CollectPartialType a (Rep s))-  , GAsType (Rep s) a+  , ErrorUnlessOne a s (CollectPartialType as (Rep s))+  , as ~ TupleToList a+  , ListTuple a as+  , GAsType (Rep s) as   ) => AsType a s where -  _Typed-    = repIso . _GTyped-  injectTyped-    = to . ginjectTyped-  projectTyped-    = either (const Nothing) Just . gprojectTyped . from+  _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta+  {-# INLINE _Typed #-}  -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} AsType a Void where

@@ -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

@@ -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)

@@ -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

@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}+{-# OPTIONS_GHC -dsuppress-all #-}  {-# LANGUAGE AllowAmbiguousTypes             #-} {-# LANGUAGE DataKinds                       #-}@@ -14,10 +15,25 @@  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.Lens+import Data.Generics.Internal.VL.Prism+import Data.Generics.Internal.VL.Traversal +-- This is sufficient at we only want to test that they typecheck+import Test24 ()+import Test25 ()+ 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 +49,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 +71,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@@ -81,10 +196,45 @@ typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b typeChangingGenericCompose = field @"fieldA" . field @"fieldA" -inspect $ 'fieldALensManual === 'fieldALensName-inspect $ 'fieldALensManual === 'fieldALensType-inspect $ 'fieldALensManual === 'fieldALensPos-inspect $ 'subtypeLensManual === 'subtypeLensGeneric-inspect $ 'typeChangingManual === 'typeChangingGeneric-inspect $ 'typeChangingManual === 'typeChangingGenericPos-inspect $ 'typeChangingManualCompose === 'typeChangingGenericCompose+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++tests :: Test+tests = TestList $ map mkHUnitTest+  [ $(inspectTest $ 'fieldALensManual          === 'fieldALensName)+  , $(inspectTest $ 'fieldALensManual          === 'fieldALensType)+  , $(inspectTest $ 'fieldALensManual          === 'fieldALensPos)+  , $(inspectTest $ 'subtypeLensManual         === 'subtypeLensGeneric)+  , $(inspectTest $ 'typeChangingManual        === 'typeChangingGeneric)+  , $(inspectTest $ 'typeChangingManual        === 'typeChangingGenericPos)+  , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)+  , $(inspectTest $ 'sum1PrismManual           === 'sum1PrismB)+  , $(inspectTest $ 'subtypePrismManual        === 'subtypePrismGeneric)+  , $(inspectTest $ 'sum2PrismManualChar       === 'sum2TypePrismChar)+  , $(inspectTest $ 'sum2PrismManual           === 'sum2TypePrism)+  , $(inspectTest $ 'sum1PrismManualChar       === 'sum1TypePrismChar)+  , $(inspectTest $ 'sum2PrismManualChar       === 'sum2TypePrismChar)+  , $(inspectTest $ 'sum1PrismManual           === 'sum1TypePrism)+  --, $(inspectTest $ 'intTraversalManual        === 'intTraversalDerived)+  --, $(inspectTest $ 'sum3Param0Manual          === 'sum3Param0Derived)+  -- TODO [1.0.0.0]: these tests pass with the new implementation+--  , $(inspectTest $ 'sum3Param1Manual          === 'sum3Param1Derived)+--  , $(inspectTest $ 'sum3Param2Manual          === 'sum3Param2Derived)+  ]++-- TODO: add test for traversals over multiple types

@@ -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

@@ -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)

@@ -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)

@@ -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+

@@ -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 _        = []